diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -12,9 +12,38 @@
## Installing zwirn
-See in the [the wiki](https://codeberg.org/uzu/zwirn/wiki/Installation).
+Currently, the easiest way to play with zwirn is through the small terminal UI zwirnmill, which comes with the sound engine [doux](https://doux.livecoding.fr/) bundled.
+You can grab a release for your operating system [here](https://github.com/polymorphicengine/zwirnmill-release/releases).
+## Compiling from Source
-## Documentation
+To compile zwirnmill or zwirnzi with Doux as the sound engine, you will need both Haskell and Rust installed. Then, clone the following repositories:
-documentation for zwirn is still in progress and available [here](https://codeberg.org/uzu/zwirn/wiki), feel free to drop me a message if you have any questions.
+```
+git clone https://codeberg.org/uzu/zwirn/
+git clone https://codeberg.org/polymorphicengine/haskell-doux
+```
+
+Now we will compile `doux-ffi`:
+
+```
+cd haskell-doux/doux-ffi
+cargo build --release
+```
+
+Then you will have to edit the paths in `zwirn/cabal.project.local` to point to your `haskell-doux` folder.
+Now we are ready to install zwirnzi or zwirnmill:
+
+```
+cd zwirn
+cabal install zwirnzi
+cabal install zwirnmill
+```
+
+If you want to use `zwirnzi` with SuperCollider / SuperDirt instead, the installation is simpler:
+
+```
+git clone https://codeberg.org/uzu/zwirn/
+cd zwirn
+cabal install zwirnzi --flags +superdirt
+```
diff --git a/app/zwirnmill/Animation.hs b/app/zwirnmill/Animation.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Animation.hs
@@ -0,0 +1,121 @@
+module Animation where
+
+import Brick (Widget)
+import qualified Brick.Animation as A
+import Brick.BChan (writeBChan)
+import Brick.Types (EventM)
+import Brick.Widgets.Core (fill, hBox, txt, vBox)
+import Control.Exception (IOException, try)
+import Control.Monad (forM)
+import Control.Monad.RWS
+import Data.List (sort)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import Editor.Core (OutputType (..))
+import Graphics.UI.TinyFileDialogs (inputBox, selectFolderDialog)
+import Lens.Micro (Lens', lens, (&), (.~), (^.))
+import System.Directory (listDirectory)
+import System.FilePath (())
+import qualified Text.Read as T
+import UI.Core (AnimationConfig (..), AppEvent (..), AppState (..), Content (..), Name (..), Window (Window))
+
+drawAnimationWindow :: AppState -> (Int, Int) -> Maybe (A.Animation AppState Name) -> Widget Name
+drawAnimationWindow as (_, sy) = A.renderAnimation (const $ vBox $ replicate sy (fill ' ')) as
+
+loadClipFromDirectory :: FilePath -> EventM Name AppState (Maybe (A.Clip AppState Name))
+loadClipFromDirectory dir = do
+ mfiles <- liftIO (try (listDirectory dir) :: IO (Either IOException [FilePath]))
+ case mfiles of
+ Left _ -> return Nothing
+ Right unfiles -> do
+ let files = sort unfiles
+ frames <- fmap concat $ forM files $ \f -> liftIO $ do
+ result <- try (TIO.readFile (dir f)) :: IO (Either IOException T.Text)
+ case result of
+ Left _ -> return []
+ Right content -> return [content]
+ let toClip c st = case Map.lookup Animator (asWindows st) of
+ Just (Window _ (_, sy) _ _ _) -> vBox $ map (\l -> hBox [txt l, fill ' ']) ls ++ rest
+ where
+ ls = T.lines c
+ rest = replicate (max 0 (sy - length ls)) $ fill ' '
+ Nothing -> vBox $ map txt $ T.lines c
+ case frames of
+ [] -> do
+ chan <- gets asChan
+ liftIO $ writeBChan chan (UpdateOutput (OutputError, "Failed to load animation."))
+ return Nothing
+ _ -> return $ Just $ A.newClip (map toClip frames)
+
+toggleAnimation :: EventM Name AppState ()
+toggleAnimation = do
+ mgr <- gets asAnimationManager
+ wm <- gets asWindows
+ case Map.lookup Animator wm of
+ Just (Window _ _ (AnimationContent Nothing (AnimationConfig i p)) _ _) -> do
+ mc <- loadClipFromDirectory p
+ case mc of
+ Just c -> A.startAnimation mgr c (fromIntegral i) A.Loop animatorWindowL
+ Nothing -> return ()
+ Just (Window _ _ (AnimationContent (Just a) _) _ _) -> A.stopAnimation mgr a
+ _ -> return ()
+
+startAnimation :: EventM Name AppState ()
+startAnimation = do
+ mgr <- gets asAnimationManager
+ wm <- gets asWindows
+ case Map.lookup Animator wm of
+ Just (Window _ _ (AnimationContent _ (AnimationConfig i p)) _ _) -> do
+ mc <- loadClipFromDirectory p
+ case mc of
+ Just c -> A.startAnimation mgr c (fromIntegral i) A.Loop animatorWindowL
+ Nothing -> return ()
+ _ -> return ()
+
+stopAnimation :: EventM Name AppState ()
+stopAnimation = do
+ mgr <- gets asAnimationManager
+ wm <- gets asWindows
+ case Map.lookup Animator wm of
+ Just (Window _ _ (AnimationContent (Just a) _) _ _) -> A.stopAnimation mgr a
+ _ -> return ()
+
+asWindowsL :: Lens' AppState (Map.Map Name Window)
+asWindowsL = lens asWindows (\st newMap -> st {asWindows = newMap})
+
+animatorWindowL :: Lens' AppState (Maybe (A.Animation AppState Name))
+animatorWindowL = lens getter setter
+ where
+ getter st = case Map.lookup Animator (st ^. asWindowsL) of
+ Just (Window _ _ (AnimationContent a _) _ _) -> a
+ _ -> Nothing
+
+ setter st newAnim =
+ let alt (Just (Window x y (AnimationContent _ conf) z l)) = Just $ Window x y (AnimationContent newAnim conf) z l
+ alt x = x
+ in st & asWindowsL .~ Map.alter alt Animator (st ^. asWindowsL)
+
+changeAnimation :: EventM Name AppState ()
+changeAnimation = do
+ mPath <- liftIO $ selectFolderDialog "Choose a folder containing animation frames" ""
+ case mPath of
+ Just path -> do
+ let alt (Just (Window x y (AnimationContent a (AnimationConfig i _)) z l)) = Just $ Window x y (AnimationContent a (AnimationConfig i (T.unpack path))) z l
+ alt _ = Nothing
+ stopAnimation
+ modify $ \as -> as {asWindows = Map.alter alt Animator $ asWindows as}
+ startAnimation
+ Nothing -> return ()
+
+changeFramerate :: EventM Name AppState ()
+changeFramerate = do
+ mframe <- ((T.readMaybe . T.unpack) =<<) <$> liftIO (inputBox "" "Choose a framerate in milliseconds" (Just "150"))
+ case mframe of
+ Just frame -> do
+ let alt (Just (Window x y (AnimationContent a (AnimationConfig _ p)) z l)) = Just $ Window x y (AnimationContent a (AnimationConfig frame p)) z l
+ alt _ = Nothing
+ stopAnimation
+ modify $ \as -> as {asWindows = Map.alter alt Animator $ asWindows as}
+ startAnimation
+ Nothing -> return ()
diff --git a/app/zwirnmill/Config.hs b/app/zwirnmill/Config.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Config.hs
@@ -0,0 +1,273 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Config where
+
+{-
+ Config.hs - configuration
+ Copyright (C) 2023, Martin Gius
+
+ This library is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this library. If not, see .
+-}
+
+import Brick.BChan (writeBChan)
+import Brick.Types (EventM)
+import Conferer (fetch, mkConfig')
+import Conferer.Config ((/.))
+import Conferer.FromConfig (DefaultConfig (..))
+import qualified Conferer.FromConfig as Conf
+import qualified Conferer.Source.CLIArgs as Cli
+import qualified Conferer.Source.Env as Env
+import qualified Conferer.Source.Yaml as Yaml
+import Control.Concurrent (forkIO)
+import Control.Monad (unless)
+import Control.Monad.RWS
+import qualified Data.ByteString.Lazy.UTF8 as BL
+import Data.Functor (void)
+import Data.Maybe (fromMaybe)
+import Data.Ratio ((%))
+import qualified Data.Text as T
+import Data.Yaml (ToJSON (..), encodeFile, object, (.=))
+import Editor.Core (OutputType (..))
+import Graphics.UI.TinyFileDialogs (selectFolderDialog)
+import Keymap
+import System.Directory.OsPath
+import System.File.OsPath as F
+import System.OsPath
+import UI.Core (AppEvent (..), AppState (..), Name)
+import Zwirn.Doux.Types (defaultDouxClockConfig)
+import qualified Zwirn.Doux.Types as Stream
+import Zwirn.Language (StreamType (Doux))
+import Zwirn.Language.Compiler (CIError (..), Environment (..), compilerInterpreterBoot, runCI)
+import qualified Zwirn.Language.Compiler as Compiler
+import Prelude hiding (log)
+
+data StreamConfig = StreamConfig
+ { streamConfigSamples :: Maybe FilePath,
+ streamConfigInput :: Maybe String,
+ streamConfigOutput :: Maybe String,
+ streamConfigHost :: Maybe String,
+ streamConfigBufferSize :: Int,
+ streamConfigChannels :: Int,
+ streamConfigBlockSize :: Int,
+ streamConfigMaxVoices :: Int
+ }
+ deriving (Show)
+
+data CiConfig = CiConfig
+ { ciConfigBootPath :: FilePath,
+ ciConfigOverwriteBuiltin :: Bool,
+ ciConfigDynamicTypes :: Bool,
+ ciConfigPrecision :: Int
+ }
+ deriving (Show)
+
+data FullConfig = FullConfig
+ { fullConfigCi :: CiConfig,
+ fullConfigStream :: StreamConfig
+ }
+ deriving (Show)
+
+instance DefaultConfig CiConfig where
+ configDef = CiConfig "" False False 288
+
+instance DefaultConfig StreamConfig where
+ configDef = StreamConfig Nothing Nothing Nothing Nothing 256 2 32 128
+
+instance DefaultConfig FullConfig where
+ configDef = FullConfig configDef configDef
+
+instance Conf.FromConfig StreamConfig where
+ fromConfig key configSource = do
+ path <- Conf.fetchFromConfig (key /. "samples") configSource
+ input <- Conf.fetchFromConfig (key /. "input") configSource
+ output <- Conf.fetchFromConfig (key /. "output") configSource
+ host <- Conf.fetchFromConfig (key /. "host") configSource
+ bs <- Conf.fetchFromConfig (key /. "buffersize") configSource
+ cs <- Conf.fetchFromConfig (key /. "channels") configSource
+ bl <- Conf.fetchFromConfig (key /. "blocksize") configSource
+ mx <- Conf.fetchFromConfig (key /. "maxvoices") configSource
+ return $ StreamConfig path input output host (fromMaybe 256 bs) (fromMaybe 2 cs) (fromMaybe 32 bl) (fromMaybe 128 mx)
+
+instance Conf.FromConfig CiConfig where
+ fromConfig key configSource = do
+ path <- Conf.fetchFromConfig (key /. "bootpath") configSource
+ bp <- Conf.fetchFromConfig (key /. "overwritebuiltin") configSource
+ dt <- Conf.fetchFromConfig (key /. "dynamictypes") configSource
+ prec <- Conf.fetchFromConfig (key /. "precision") configSource
+ return $ CiConfig (fromMaybe "" path) (fromMaybe False bp) (fromMaybe False dt) (fromMaybe 288 prec)
+
+instance Conf.FromConfig FullConfig where
+ fromConfig key configSource = do
+ ci <- Conf.fetchFromConfig (key /. "ci") configSource
+ str <- Conf.fetchFromConfig (key /. "stream") configSource
+ return $ FullConfig ci (fromMaybe configDef str)
+
+instance ToJSON CiConfig where
+ toJSON (CiConfig p o d prec) =
+ object
+ [ "bootpath" .= p,
+ "overwritebuiltin" .= o,
+ "dynamictypes" .= d,
+ "precision" .= prec
+ ]
+
+instance ToJSON StreamConfig where
+ toJSON (StreamConfig sam inp out host buf chan block maxv) =
+ object
+ [ "samples" .= sam,
+ "host" .= host,
+ "input" .= inp,
+ "output" .= out,
+ "buffersize" .= buf,
+ "channels" .= chan,
+ "blocksize" .= block,
+ "maxvoices" .= maxv
+ ]
+
+instance ToJSON FullConfig where
+ toJSON (FullConfig ci str) =
+ object
+ [ "ci" .= toJSON ci,
+ "stream" .= toJSON str
+ ]
+
+getConfigPath :: IO OsPath
+getConfigPath = do
+ appname <- encodeUtf "zwirnmill"
+ configname <- encodeUtf "config.yaml"
+ configDirPath <- getXdgDirectory XdgConfig appname
+ let path = configDirPath configname
+ createDirectoryIfMissing True configDirPath
+ return path
+
+getKeymapPath :: IO OsPath
+getKeymapPath = do
+ appname <- encodeUtf "zwirnmill"
+ configname <- encodeUtf "keymap.yaml"
+ configDirPath <- getXdgDirectory XdgConfig appname
+ return $ configDirPath configname
+
+getConfig :: IO (FullConfig, CustomKeymap)
+getConfig = do
+ path <- getConfigPath
+ kmpath <- getKeymapPath
+ exists <- doesFileExist path
+ existskm <- doesFileExist kmpath
+ unless exists encodeDefault
+ unless existskm (encodeKeymap configDef)
+ decoded <- decodeUtf path
+ decodedkm <- decodeUtf kmpath
+ keymapConf <- mkConfig' [] [Yaml.fromFilePath decodedkm]
+ conf <-
+ mkConfig'
+ []
+ [ Cli.fromConfig,
+ Env.fromConfig "zwirnmill",
+ Yaml.fromFilePath decoded
+ ]
+ full <- fetch conf
+ keymap <- fetch keymapConf
+ return (full, keymap)
+
+toStream :: Rational -> StreamConfig -> Stream.StreamConfig
+toStream prec (StreamConfig a b c d e f g h) = Stream.StreamConfig prec a b c d e f g h defaultDouxClockConfig
+
+toCiConfig :: CiConfig -> Compiler.CiConfig
+toCiConfig (CiConfig _ x y z) = Compiler.CiConfig x y (1 % fromIntegral z) Doux
+
+configPath :: IO String
+configPath = do
+ path <- getConfigPath
+ exists <- doesFileExist path
+ decoded <- decodeUtf path
+ if exists then return decoded else return "Config file not found!"
+
+resetConfig :: IO String
+resetConfig = encodeDefault >> return "Restored default config."
+
+encodeDefault :: IO ()
+encodeDefault = encodeConfig configDef
+
+encodeConfig :: FullConfig -> IO ()
+encodeConfig conf = do
+ path <- getConfigPath
+ strp <- decodeFS path
+ encodeFile strp $ toJSON conf
+
+encodeKeymap :: CustomKeymap -> IO ()
+encodeKeymap conf = do
+ path <- getKeymapPath
+ strp <- decodeFS path
+ encodeFile strp $ toJSON conf
+
+getFile :: String -> IO String
+getFile p = do
+ path <- encodeUtf p
+ f <- F.readFile path
+ return $ BL.toString f
+
+setBootPath :: EventM Name AppState ()
+setBootPath = do
+ mpath <- liftIO $ openFolder "choose a boot folder"
+ case mpath of
+ Just path -> do
+ env <- gets asEnvironment
+ chan <- gets asChan
+ menv <- liftIO $ checkBoot (\st -> void $ forkIO $ writeBChan chan (UpdateOutput (OutputInfo, st))) path env
+ case menv of
+ Just env' -> do
+ (FullConfig ci str, _) <- liftIO getConfig
+ modify $ \as -> as {asEnvironment = env'}
+ liftIO $ encodeConfig $ FullConfig ci {ciConfigBootPath = path} str
+ Nothing -> return ()
+ Nothing -> return ()
+
+setSamplePath :: EventM Name AppState ()
+setSamplePath = do
+ mpath <- liftIO $ openFolder "choose a sample folder"
+ case mpath of
+ Just path -> do
+ chan <- gets asChan
+ (FullConfig ci str, _) <- liftIO getConfig
+ liftIO $ encodeConfig $ FullConfig ci str {streamConfigSamples = Just path}
+ liftIO $ void $ forkIO $ writeBChan chan (UpdateOutput (OutputInfo, "Successfully set sample folder path. \nRestart for it to take effect."))
+ Nothing -> return ()
+
+openFolder :: T.Text -> IO (Maybe FilePath)
+openFolder msg = fmap T.unpack <$> selectFolderDialog msg ""
+
+checkBoot :: (String -> IO ()) -> FilePath -> Environment -> IO (Maybe Environment)
+checkBoot log "" _ = log "Starting without Bootfile." >> return Nothing
+checkBoot log path env = do
+ ospath <- encodeUtf path
+ isfile <- doesFileExist ospath
+ ps <-
+ if isfile
+ then return $ decodeUtf ospath
+ else do
+ isfolder <- doesDirectoryExist ospath
+ if isfolder
+ then do
+ pss <- listDirectory ospath
+ fs <- mapM decodeUtf pss
+ return $ map (\f -> path ++ "/" ++ f) fs
+ else return []
+ res <- runCI env (compilerInterpreterBoot $ map T.pack ps)
+ case res of
+ Left (CIError err _) -> log ("Error in Bootfile: " ++ show err) >> return Nothing
+ Right newEnv ->
+ if ps /= []
+ then log ("Successfully loaded Bootfiles from " ++ path) >> return (Just newEnv)
+ else log ("No Bootfiles found at " ++ path) >> return Nothing
diff --git a/app/zwirnmill/Docs/Draw.hs b/app/zwirnmill/Docs/Draw.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Docs/Draw.hs
@@ -0,0 +1,82 @@
+{- HLINT ignore "Use tuple-section" -}
+module Docs.Draw where
+
+import Brick (ViewportType (..), Widget (..), hBox, textWidth)
+import Brick.Types (Location (..), VScrollBarOrientation (..))
+import Brick.Widgets.Core (clickable, translateBy, txt, vBox, viewport, withAttr, withVScrollBars)
+import Data.Bifunctor (second)
+import Data.List (intersperse, mapAccumL)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Docs.Markdown
+import Docs.Util
+import Editor.Draw (renderTokens, tokenizeLine)
+import UI.Attributes (attrCurrentLink, attrDocCode, attrDocEmph, attrDocStrong, attrLink)
+import UI.Core (Doc (..), DocBlock (..), DocFocus (..), DocInline (..), DocMap, DocStyle (..), Name (..))
+
+drawDoc :: (Int, Int) -> Doc -> DocFocus -> Widget Name
+drawDoc (sx, _) (Doc ds) c = withVScrollBars OnRight $ viewport DocViewport Vertical $ vBox $ intersperse (txt "\n") $ snd $ mapAccumL (drawDocBlock (sx - 3) c) (0, 0) ds
+
+drawDocBlock :: Int -> DocFocus -> (Int, Int) -> DocBlock -> ((Int, Int), Widget Name)
+drawDocBlock sx c (i, j) (Paragraph is) = ((i, j + x), vBox ps)
+ where
+ (x, ps) = drawParagraph c j sx is
+drawDocBlock _ c (i, j) (CodeBlock t) = ((i + 1, j), drawCodeBlock c i t)
+
+drawCodeBlock :: DocFocus -> Int -> T.Text -> Widget Name
+drawCodeBlock c i t = clickable (DocCode i) block
+ where
+ ls = T.lines t
+ tok =
+ if currentCodeBlock c i
+ then
+ renderTokens . tokenizeLine (Just (0, 0)) (length ls, 0) 0 []
+ else renderTokens . tokenizeLine Nothing (1, -1) (-1) []
+ block = translateBy (Location (2, 0)) $ vBox $ map tok ls
+
+drawParagraph :: DocFocus -> Int -> Int -> [DocInline] -> (Int, [Widget Name])
+drawParagraph cur ln maxwd ds = case drawParagraphLine cur ln maxwd 0 [] ds of
+ (ln', _, ws, []) -> (ln', [hBox ws])
+ (ln', _, ws, rs) -> second (hBox ws :) $ drawParagraph cur ln' maxwd rs
+
+drawParagraphLine :: DocFocus -> Int -> Int -> Int -> [Widget Name] -> [DocInline] -> (Int, Int, [Widget Name], [DocInline])
+drawParagraphLine _ ln _ wd ps [] = (ln, wd, ps, [])
+drawParagraphLine _ ln _ wd ps (Linebreak : ds) = (ln, wd, ps, ds)
+drawParagraphLine cur ln maxwd wd ps (TextChunk t s : ds) =
+ if wd + curWd > maxwd
+ then
+ if curWd >= maxwd
+ then (ln, wd + curWd, ps ++ [withDocStyle s $ txt t], ds)
+ else (ln, wd + curWd, ps, TextChunk t s : ds)
+ else drawParagraphLine cur ln maxwd (wd + curWd) (ps ++ [withDocStyle s $ txt t]) ds
+ where
+ curWd = textWidth t
+drawParagraphLine cur ln maxwd wd ps (Link t d : ds) =
+ if wd + curWd > maxwd
+ then
+ if curWd >= maxwd
+ then (ln + 1, wd + curWd, ps ++ [linkAttr ln $ txt t], ds)
+ else (ln, wd + curWd, ps, Link t d : ds)
+ else drawParagraphLine cur (ln + 1) maxwd (wd + curWd) (ps ++ [linkAttr ln $ txt t]) ds
+ where
+ curWd = textWidth t
+ linkAttr x = clickable (DocLink ln) . if currentLink cur x then withAttr attrCurrentLink else withAttr attrLink
+
+withDocStyle :: DocStyle -> (Widget n -> Widget n)
+withDocStyle Normal = id
+withDocStyle Strong = withAttr attrDocStrong
+withDocStyle Emph = withAttr attrDocEmph
+withDocStyle Code = withAttr attrDocCode
+
+example :: Doc
+example = case parseDoc "Welcome to the Zwirn Documentation!\n This is another line.\n\n Here is a new paragraph. \n Here is a workking [link](other)\n\n\n and another [link](lololol)\n\n\n```\n1 $: s \"kick\"\n # speed 2\n```" of
+ Left _ -> Doc []
+ Right x -> x
+
+example2 :: Doc
+example2 = case parseDoc "This is another example page in the documentation.\n [This](start) links back to the other page." of
+ Left _ -> Doc []
+ Right x -> x
+
+exampleMap :: DocMap
+exampleMap = Map.fromList [("start", example), ("other", example2)]
diff --git a/app/zwirnmill/Docs/Event.hs b/app/zwirnmill/Docs/Event.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Docs/Event.hs
@@ -0,0 +1,69 @@
+module Docs.Event where
+
+import Brick (BrickEvent (..), EventM, ViewportScroll (..), gets, modify)
+import Brick.Main (viewportScroll)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Docs.Util
+import Editor.File (copyToClipboard)
+import qualified Graphics.Vty as V
+import UI.Core (AppState (..), Content (..), Doc (..), DocFocus (..), DocMap, Name (..), Window (..))
+import Zwirn.Language.Compiler (Environment, compilerInterpreterWithBlock, runCI)
+
+handleDocEvent :: Doc -> DocFocus -> DocMap -> BrickEvent Name e -> EventM Name AppState (Doc, DocFocus)
+handleDocEvent d f _ (VtyEvent (V.EvKey (V.KChar '\t') _)) = return (d, moveNext d f)
+handleDocEvent d (CodeFocus i) _ (VtyEvent (V.EvKey V.KEnter _)) = evalCodeEvent d i
+handleDocEvent d (CodeFocus i) _ (VtyEvent (V.EvKey (V.KChar 'c') [V.MCtrl])) = copyCodeEvent d i >> return (d, CodeFocus i)
+handleDocEvent d (LinkFocus i) m (VtyEvent (V.EvKey V.KEnter _)) = gotoLink d i m >>= \x -> vScrollToBeginning (viewportScroll DocViewport) >> return x
+handleDocEvent d f _ (MouseDown name V.BScrollUp _ _) = when (isDoc name) (vScrollBy (viewportScroll DocViewport) (-1)) >> return (d, f)
+handleDocEvent d f _ (MouseDown name V.BScrollDown _ _) = when (isDoc name) (vScrollBy (viewportScroll DocViewport) 1) >> return (d, f)
+handleDocEvent d f _ _ = return (d, f)
+
+isDoc :: Name -> Bool
+isDoc Documentation = True
+isDoc (DocLink _) = True
+isDoc (DocCode _) = True
+isDoc DocViewport = True
+isDoc _ = False
+
+gotoLink :: Doc -> Int -> DocMap -> EventM Name AppState (Doc, DocFocus)
+gotoLink d i m = case getLinkAt d i of
+ Nothing -> return (d, LinkFocus i)
+ Just dest -> case Map.lookup dest m of
+ Just d' -> return (d', moveNext d' NoFocus)
+ Nothing -> return (d, LinkFocus i)
+
+gotoStart :: EventM Name AppState ()
+gotoStart = modify $ \as -> as {asWindows = Map.alter alt Documentation $ asWindows as}
+ where
+ alt (Just (Window x y (DocumentationContent _ _ m) a b)) = do
+ st <- Map.lookup "welcome.md" m
+ Just $ Window x y (DocumentationContent st (moveNext st NoFocus) m) a b
+ alt x = x
+
+evalCodeEvent :: Doc -> Int -> EventM Name AppState (Doc, DocFocus)
+evalCodeEvent d i = case getCodeAt d i of
+ Nothing -> return (d, CodeFocus i)
+ Just cont -> do
+ env <- gets asEnvironment
+ env' <- liftIO $ evalCode cont env
+ modify $ \as -> as {asEnvironment = env'}
+ return (d, CodeFocus i)
+
+copyCodeEvent :: Doc -> Int -> EventM Name AppState ()
+copyCodeEvent d i = case getCodeAt d i of
+ Nothing -> return ()
+ Just t -> do
+ vtyOut <- gets asVtyOutput
+ case vtyOut of
+ Nothing -> return ()
+ Just out -> liftIO (copyToClipboard out t)
+
+evalCode :: T.Text -> Environment -> IO Environment
+evalCode cont env = do
+ x <- runCI env (compilerInterpreterWithBlock 0 cont)
+ case x of
+ Left _ -> return env
+ Right (_, env', _) -> return env'
diff --git a/app/zwirnmill/Docs/Markdown.hs b/app/zwirnmill/Docs/Markdown.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Docs/Markdown.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Docs.Markdown where
+
+import Commonmark
+import qualified Data.ByteString as BS
+import Data.Char (isPunctuation, isSpace)
+import Data.FileEmbed (embedDir)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified System.FilePath as Native
+import qualified System.FilePath.Posix as Posix
+import UI.Core (Doc (..), DocBlock (..), DocInline (..), DocMap, DocStyle (..))
+
+instance Semigroup Doc where
+ Doc a <> Doc b = Doc (a <> b)
+
+instance Monoid Doc where
+ mempty = Doc []
+
+instance Rangeable Doc where
+ ranged _ x = x
+
+instance Rangeable [DocInline] where
+ ranged _ x = x
+
+instance HasAttributes Doc where
+ addAttributes _ x = x
+
+instance HasAttributes [DocInline] where
+ addAttributes _ x = x
+
+instance IsInline [DocInline] where
+ lineBreak = [Linebreak]
+ softBreak = [Linebreak]
+ str s = [TextChunk s Normal]
+ entity e = [TextChunk e Normal]
+ escapedChar c = [TextChunk (T.singleton c) Normal]
+ emph = map toEmph
+ where
+ toEmph (TextChunk x _) = TextChunk x Emph
+ toEmph x = x
+ strong = map toStrong
+ where
+ toStrong (TextChunk x _) = TextChunk x Strong
+ toStrong x = x
+ code c = [TextChunk c Code]
+ rawInline _fmt t = [TextChunk t Normal]
+ link dest _title l = [Link (T.concat $ map labelText l) dest]
+ image dest _title l = [Link (T.concat $ map labelText l) dest]
+
+labelText :: DocInline -> Text
+labelText (TextChunk t _) = t
+labelText (Link t _) = t
+labelText Linebreak = ""
+
+instance IsBlock [DocInline] Doc where
+ paragraph is = Doc [Paragraph $ mergePunctuation is]
+ plain is = Doc [Paragraph $ mergePunctuation is]
+ thematicBreak = Doc [Paragraph [TextChunk "\n---\n" Normal]]
+ blockQuote = id
+ codeBlock _info ct = Doc [CodeBlock ct]
+ heading _lvl is = Doc [Paragraph is]
+ rawBlock _fmt t = Doc [Paragraph [TextChunk t Normal]]
+ referenceLinkDefinition _ _ = mempty
+ list _ty _spacing = mconcat
+
+mergePunctuation :: [DocInline] -> [DocInline]
+mergePunctuation (TextChunk a s1 : TextChunk b s2 : ds)
+ | T.all isSpace b = TextChunk a s1 : TextChunk b s2 : mergePunctuation ds
+ | T.all isSpace a = TextChunk a s1 : mergePunctuation (TextChunk b s2 : ds)
+ | isPuncBack a || isPuncFront b = mergePunctuation $ TextChunk (a <> b) s1 : ds
+ | otherwise = TextChunk a s1 : mergePunctuation (TextChunk b s2 : ds)
+ where
+ isPuncFront x = case T.uncons x of
+ Just (c, _) -> isPunctuation c
+ Nothing -> False
+ isPuncBack x = case T.unsnoc x of
+ Just (_, c) -> isPunctuation c
+ Nothing -> False
+mergePunctuation (d : ds) = d : mergePunctuation ds
+mergePunctuation x = x
+
+parseDoc :: Text -> Either ParseError Doc
+parseDoc src =
+ case commonmark "input" src of
+ Left err -> Left err
+ Right blocks -> Right blocks
+
+normalizePath :: FilePath -> String
+normalizePath = Posix.joinPath . Native.splitDirectories
+
+embeddedFilesList :: [(FilePath, BS.ByteString)]
+embeddedFilesList = $(embedDir "docs")
+
+docMap :: DocMap
+docMap = Map.fromList [(T.pack $ normalizePath path, toDoc content) | (path, content) <- embeddedFilesList]
+ where
+ toDoc bs = case parseDoc $ TE.decodeUtf8 bs of
+ Left err -> error $ "Error in parsing documentation:" <> show err
+ Right x -> x
+
+startDoc :: Doc
+startDoc = fromMaybe (error "Failed to get start Documentation!") $ Map.lookup "welcome.md" docMap
diff --git a/app/zwirnmill/Docs/Util.hs b/app/zwirnmill/Docs/Util.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Docs/Util.hs
@@ -0,0 +1,55 @@
+module Docs.Util where
+
+import Data.Bifunctor (second)
+import Data.List (elemIndex, mapAccumL, (!?))
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import UI.Core (Doc (..), DocBlock (..), DocFocus (..), DocInline (..))
+
+getCodeAt :: Doc -> Int -> Maybe T.Text
+getCodeAt (Doc []) _ = Nothing
+getCodeAt (Doc ((CodeBlock t) : _)) 0 = Just t
+getCodeAt (Doc ((CodeBlock _) : ds)) n = getCodeAt (Doc ds) (n - 1)
+getCodeAt (Doc (_ : ds)) n = getCodeAt (Doc ds) n
+
+getLinkAt :: Doc -> Int -> Maybe T.Text
+getLinkAt (Doc []) _ = Nothing
+getLinkAt (Doc ((Paragraph ps) : ds)) n = case getLinkAtPar ps n of
+ Left i -> getLinkAt (Doc ds) i
+ Right x -> Just x
+getLinkAt (Doc ((CodeBlock _) : ds)) n = getLinkAt (Doc ds) n
+
+getLinkAtPar :: [DocInline] -> Int -> Either Int T.Text
+getLinkAtPar [] i = Left i
+getLinkAtPar ((Link _ d) : _) 0 = Right d
+getLinkAtPar ((Link _ _) : ds) n = getLinkAtPar ds (n - 1)
+getLinkAtPar (_ : ds) n = getLinkAtPar ds n
+
+currentLink :: DocFocus -> Int -> Bool
+currentLink (LinkFocus t) k = t == k
+currentLink _ _ = False
+
+currentCodeBlock :: DocFocus -> Int -> Bool
+currentCodeBlock (CodeFocus i) j = i == j
+currentCodeBlock _ _ = False
+
+docFoci :: Doc -> [DocFocus]
+docFoci (Doc ds) = concat $ snd $ mapAccumL getFociBlock (0, 0) ds
+
+getFociBlock :: (Int, Int) -> DocBlock -> ((Int, Int), [DocFocus])
+getFociBlock (i, j) (CodeBlock _) = ((i + 1, j), [CodeFocus i])
+getFociBlock (i, j) (Paragraph ls) = second concat $ mapAccumL getFociInline (i, j) ls
+
+getFociInline :: (Int, Int) -> DocInline -> ((Int, Int), [DocFocus])
+getFociInline (i, j) (Link _ _) = ((i, j + 1), [LinkFocus j])
+getFociInline (i, j) _ = ((i, j), [])
+
+moveNext :: Doc -> DocFocus -> DocFocus
+moveNext d NoFocus = fromMaybe NoFocus $ docFoci d !? 0
+moveNext d cur = next
+ where
+ fs = docFoci d
+ i = fromMaybe 0 $ elemIndex cur fs
+ next = case fs !? (i + 1) of
+ Just n -> n
+ Nothing -> fromMaybe cur (fs !? 0)
diff --git a/app/zwirnmill/Editor/Config.hs b/app/zwirnmill/Editor/Config.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Config.hs
@@ -0,0 +1,33 @@
+module Editor.Config where
+
+import Conferer.Config ((/.))
+import Conferer.FromConfig (FromConfig (..), fetchFromConfig)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text.Zipper (textZipper)
+import Editor.Core (EditorState (..), esTabWidth, esZipper, newEditor)
+import Editor.File (loadFile)
+import Lens.Micro
+
+data EditorConfig
+ = EditorConfig {editorConfigTabWidth :: Int, editorConfigPath :: Maybe FilePath, editorConfigContent :: Maybe T.Text}
+ deriving (Eq, Show)
+
+instance FromConfig EditorConfig where
+ fromConfig key configSource = do
+ r <- fetchFromConfig (key /. "tabwidth") configSource
+ p <- fetchFromConfig (key /. "path") configSource
+ cont <- fetchFromConfig (key /. "content") configSource
+ return (EditorConfig (fromMaybe 4 r) p cont)
+
+editorFromConfig :: EditorConfig -> IO EditorState
+editorFromConfig (EditorConfig tw Nothing Nothing) = return $ newEditor & esTabWidth .~ tw
+editorFromConfig (EditorConfig tw Nothing (Just c)) =
+ return $
+ newEditor
+ & esTabWidth .~ tw
+ & esZipper .~ textZipper (T.lines c) Nothing
+editorFromConfig (EditorConfig tw (Just path) _) = do
+ contents <- readFile path
+ let es = loadFile path (T.pack contents)
+ return $ es & esTabWidth .~ tw
diff --git a/app/zwirnmill/Editor/Core.hs b/app/zwirnmill/Editor/Core.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Core.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Editor.Core where
+
+import qualified Data.Text as T
+import Data.Text.Zipper
+import Lens.Micro.TH (makeLenses)
+
+data Diagnostic = Diagnostic
+ { diagnosticLoc :: ((Int, Int), (Int, Int)),
+ diagnosticText :: String
+ }
+ deriving (Eq, Show)
+
+data UndoEntry = UndoEntry
+ { undoZipper :: TextZipper T.Text,
+ undoSelection :: Maybe (Int, Int)
+ }
+ deriving (Eq, Show)
+
+data Popup = Popup
+ { popupContent :: String,
+ popupPosition :: (Int, Int)
+ }
+ deriving (Eq, Show)
+
+data OutputType
+ = OutputError
+ | OutputInfo
+ deriving (Eq, Show)
+
+data EditorState = EditorState
+ { _esZipper :: TextZipper T.Text,
+ _esDiagnostics :: [Diagnostic],
+ _esFilePath :: Maybe FilePath,
+ _esUnsaved :: Bool,
+ _esUndoStack :: [UndoEntry],
+ _esRedoStack :: [UndoEntry],
+ _esSelection :: Maybe (Int, Int),
+ _esFlashBlock :: Maybe (OutputType, (Int, Int)),
+ _esTabWidth :: Int,
+ _esMessage :: Maybe String,
+ _esPopup :: Maybe Popup
+ }
+ deriving (Eq, Show)
+
+makeLenses ''EditorState
+
+newEditor :: EditorState
+newEditor =
+ EditorState
+ { _esZipper = textZipper [] Nothing,
+ _esDiagnostics = [],
+ _esFilePath = Nothing,
+ _esUnsaved = False,
+ _esUndoStack = [],
+ _esRedoStack = [],
+ _esSelection = Nothing,
+ _esFlashBlock = Nothing,
+ _esTabWidth = 4,
+ _esMessage = Nothing,
+ _esPopup = Nothing
+ }
diff --git a/app/zwirnmill/Editor/Cursor.hs b/app/zwirnmill/Editor/Cursor.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Cursor.hs
@@ -0,0 +1,94 @@
+module Editor.Cursor where
+
+import Data.Char (isSpace)
+import Data.Text (Text)
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Editor.Util
+
+moveCursorPos :: (Int, Int) -> EditorState -> EditorState
+moveCursorPos p = withZipper (Z.moveCursorClosest p) . clearSelection
+
+moveCursorUp :: EditorState -> EditorState
+moveCursorUp = withZipper Z.moveUp . clearSelection
+
+moveCursorDown :: EditorState -> EditorState
+moveCursorDown = withZipper Z.moveDown . clearSelection
+
+moveCursorLeft :: EditorState -> EditorState
+moveCursorLeft = withZipper Z.moveLeft . clearSelection
+
+moveCursorRight :: EditorState -> EditorState
+moveCursorRight = withZipper Z.moveRight . clearSelection
+
+moveCursorLineStart :: EditorState -> EditorState
+moveCursorLineStart = withZipper Z.gotoBOL . clearSelection
+
+moveCursorLineEnd :: EditorState -> EditorState
+moveCursorLineEnd = withZipper Z.gotoEOL . clearSelection
+
+moveCursorFileStart :: EditorState -> EditorState
+moveCursorFileStart = withZipper Z.gotoBOF . clearSelection
+
+moveCursorFileEnd :: EditorState -> EditorState
+moveCursorFileEnd = withZipper Z.gotoEOF . clearSelection
+
+moveCursorWordLeft :: EditorState -> EditorState
+moveCursorWordLeft = withZipper moveWordStartLeft
+
+moveCursorWordRight :: EditorState -> EditorState
+moveCursorWordRight = withZipper moveWordStartRight
+
+moveWordStartLeft :: Z.TextZipper Text -> Z.TextZipper Text
+moveWordStartLeft tz = findWordStart (findWordLeft $ Z.moveLeft tz)
+ where
+ findWordLeft x = case Z.currentChar x of
+ Nothing -> x
+ Just c ->
+ if isSpace c
+ then
+ let next = Z.moveLeft x
+ in if Z.cursorPosition next == Z.cursorPosition x
+ then x
+ else findWordLeft next
+ else x
+
+ findWordStart x =
+ let prev = Z.moveLeft x
+ in if Z.cursorPosition prev == Z.cursorPosition x
+ then x
+ else case Z.currentChar prev of
+ Nothing -> x
+ Just c ->
+ if not (isSpace c)
+ then findWordStart prev
+ else x
+
+moveWordStartRight :: Z.TextZipper Text -> Z.TextZipper Text
+moveWordStartRight tz = findWordStart (findWordRight $ Z.moveRight tz)
+ where
+ findWordRight x = case Z.currentChar x of
+ Nothing ->
+ let next = Z.moveRight x
+ in if Z.cursorPosition next == Z.cursorPosition x
+ then x
+ else findWordRight next
+ Just c ->
+ if isSpace c
+ then
+ let next = Z.moveRight x
+ in if Z.cursorPosition next == Z.cursorPosition x
+ then x
+ else findWordRight next
+ else x
+
+ findWordStart x =
+ let prev = Z.moveRight x
+ in if Z.cursorPosition prev == Z.cursorPosition x
+ then x
+ else case Z.currentChar prev of
+ Nothing -> x
+ Just c ->
+ if not (isSpace c)
+ then findWordStart prev
+ else x
diff --git a/app/zwirnmill/Editor/Diagnostic.hs b/app/zwirnmill/Editor/Diagnostic.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Diagnostic.hs
@@ -0,0 +1,43 @@
+module Editor.Diagnostic where
+
+import Brick (EventM, get)
+import Brick.Types (modify)
+import Control.Monad.IO.Class (liftIO)
+import Data.List (find)
+import Editor.Core (Diagnostic (..), EditorState, esDiagnostics)
+import Editor.Util
+import Lens.Micro
+import UI.Core (EditorEventEnv (..), Name, envEditorState)
+import Zwirn.Language (Predicate (..), TypeError (..))
+import Zwirn.Language.Compiler
+import Zwirn.Language.LSP.Diagnostics (validateCode)
+import Zwirn.Language.Location
+
+diagnoseEvent :: EventM Name EditorEventEnv ()
+diagnoseEvent = do
+ (EditorEventEnv _ _ _ _ env es) <- get
+ ds <- liftIO $ getDiagnostics es env
+ modify $ envEditorState %~ esDiagnostics .~ ds
+
+getDiagnostics :: EditorState -> Environment -> IO [Diagnostic]
+getDiagnostics es env = toDiagnostic <$> validateCode env (getContent es)
+
+toDiagnostic :: Maybe ErrorType -> [Diagnostic]
+toDiagnostic (Just (ParseErr msg (RealSrcLoc _ sr sc er ec))) = [Diagnostic ((sr, sc - 1), (er, ec - 1)) msg]
+toDiagnostic (Just err@(TypeErr (NoInstance (Located (SrcLoc (RealSrcLoc _ sr sc er ec)) (IsIn _ _))))) = [Diagnostic ((sr, sc - 1), (er, ec - 1)) (show err)]
+toDiagnostic (Just err@(TypeErr (UnboundVariable (Located (SrcLoc (RealSrcLoc _ sr sc er ec)) _)))) = [Diagnostic ((sr, sc - 1), (er, ec - 2)) (show err)]
+toDiagnostic (Just err@(TypeErr (UnificationFail (Located (SrcLoc (RealSrcLoc _ sr sc er ec)) _)))) = [Diagnostic ((sr, sc - 1), (er, ec - 1)) (show err)]
+toDiagnostic (Just (ManyErr errs)) = concatMap (toDiagnostic . Just) errs
+toDiagnostic _ = []
+
+rowDiagnostics :: Int -> [Diagnostic] -> [Diagnostic]
+rowDiagnostics row = filter (\(Diagnostic ((r1, _), (r2, _)) _) -> r1 <= row && row <= r2)
+
+inDiagnostic :: (Int, Int) -> Diagnostic -> Bool
+inDiagnostic p (Diagnostic (x, y) _) = inSpan p x y
+
+inAnyDiagnostic :: (Int, Int) -> [Diagnostic] -> Bool
+inAnyDiagnostic = any . inDiagnostic
+
+getAnyDiagnostic :: (Int, Int) -> [Diagnostic] -> Maybe Diagnostic
+getAnyDiagnostic p = find (inDiagnostic p)
diff --git a/app/zwirnmill/Editor/Draw.hs b/app/zwirnmill/Editor/Draw.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Draw.hs
@@ -0,0 +1,162 @@
+module Editor.Draw where
+
+import Brick
+import qualified Brick.Widgets.Border as Border
+import Control.Monad ((<=<))
+import Data.List (find, groupBy)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Editor.Diagnostic
+import Editor.Selection
+import Editor.Util
+import Lens.Micro
+import UI.Attributes
+import UI.Core
+import Zwirn.Language.Lexer (Lexeme, Token (..), tokenise)
+import Zwirn.Language.Location (Located (..), RealSrcLoc (..), SrcLoc (..))
+
+drawEditor :: Bool -> (Name, (Int, Int), EditorState) -> Widget Name
+drawEditor active (name, size, es) =
+ vBox
+ [ drawEditorBody active name size es,
+ vLimit 1 $ drawStatusBar es
+ ]
+
+drawStatusBar :: EditorState -> Widget Name
+drawStatusBar es =
+ let filePart = fromMaybe "[No Name]" (es ^. esFilePath)
+ unsaved = if es ^. esUnsaved then "*" else " "
+ cursor = Z.cursorPosition $ es ^. esZipper
+ pos =
+ "Ln "
+ ++ show (fst cursor + 1)
+ ++ ", Col "
+ ++ show (snd cursor + 1)
+ msg = fromMaybe "" (es ^. esMessage)
+ left = " " ++ unsaved ++ " " ++ filePart ++ " " ++ msg
+ right = pos ++ " "
+ in withAttr attrStatusBar $
+ hBox
+ [ str left,
+ fill ' ',
+ str right
+ ]
+
+drawPopup :: Maybe Popup -> Widget Name
+drawPopup Nothing = emptyWidget
+drawPopup (Just (Popup content (col, row))) = translateBy (Location (col + 1, row + 1)) $ Border.border $ str content
+
+drawEditorBody :: Bool -> Name -> (Int, Int) -> EditorState -> Widget Name
+drawEditorBody active name (sx, sy) es = hBox [lineNumbers, viewport (fromName name) Both $ visibleRegion (Location (c, r)) (1, 1) $ cursor $ vLimit (max cy sy) $ hLimit (max cx sx) $ vBox (rowWidgets ++ bottomPadding)]
+ where
+ fromName (Editor i) = EditorViewport i
+ fromName x = x
+ cy = lineCount es
+ cx = getLongestLine es
+
+ ds = es ^. esDiagnostics
+ flashed i = case es ^. esFlashBlock of
+ Nothing -> Nothing
+ Just (ty, (st, en)) -> if st <= i && i <= en then Just ty else Nothing
+ (r, c) = currentCursor es
+
+ maxLineWidth = lineNumberWidth es
+ allLines = getLines es
+
+ indexedRows = zipWith (\ro l -> (ro, l, rowDiagnostics ro ds, flashed ro)) [0 ..] allLines
+ lineNumbers = vBox $ map (drawLineNumber (fromName name) r maxLineWidth) [0 .. length allLines - 1]
+
+ rowWidgets = map (drawRow es) indexedRows
+
+ remainingRows = max 0 (sy - cy)
+ bottomPadding = replicate remainingRows (fill ' ')
+ cursor = if active then showCursor Cursor (Location (c, r)) else id
+
+drawRow :: EditorState -> (Int, Text, [Diagnostic], Maybe OutputType) -> Widget Name
+drawRow es (row, rawLine, ds, flashed) =
+ let cursor = currentCursor es
+ isCurRow = fst cursor == row
+ tokens = tokenizeLine (es ^. esSelection) cursor row ds rawLine
+ lineWidget = hBox [renderTokens tokens, fill ' ']
+ rowWidget = lineWidget
+ in case flashed of
+ Just OutputInfo -> withDefAttr attrFlash rowWidget
+ Just OutputError -> withDefAttr attrFlashError rowWidget
+ _ ->
+ if isCurRow
+ then withDefAttr attrCurrentLine rowWidget
+ else rowWidget
+
+cellAttr :: Maybe (Int, Int) -> (Int, Int) -> Int -> Int -> [Diagnostic] -> Maybe AttrName -> Maybe AttrName
+cellAttr Nothing _ row col ds@(_ : _) x = if inAnyDiagnostic (row, col) ds then Just attrError else x
+cellAttr Nothing _ _ _ _ x = x
+cellAttr (Just sel) cursor row col ds matt
+ | insel && inerr = Just $ attrSelected <> attrError
+ | insel = maybe (Just attrSelected) (\att -> Just $ attrSelected <> att) matt
+ | inerr = Just attrError
+ | otherwise = matt
+ where
+ insel = inSelection (row, col) cursor (Just sel)
+ inerr = inAnyDiagnostic (row, col) ds
+
+tokenizeLine :: Maybe (Int, Int) -> (Int, Int) -> Int -> [Diagnostic] -> Text -> [(Maybe AttrName, Text)]
+tokenizeLine mSel cursor row ds text =
+ concatMap toToken $
+ groupBy sameAttr $
+ zipWith (\col ch -> (cellAttr mSel cursor row col ds (inLexeme col ls), ch)) [0 ..] (T.unpack text)
+ where
+ toToken [] = []
+ toToken ((a, x) : pairs) = [(a, T.pack $ x : map snd pairs)]
+ sameAttr (a, _) (b, _) = a == b
+ ls = getLexemes text
+
+renderTokens :: [(Maybe AttrName, Text)] -> Widget Name
+renderTokens ts = hBox [maybe (txt s) (\a -> withAttr a (txt s)) attr | (attr, s) <- ts]
+
+drawLineNumber :: Name -> Int -> Int -> Int -> Widget Name
+drawLineNumber vpn currentRow maxWidth row = Widget Fixed Fixed $ do
+ vp <- unsafeLookupViewport vpn
+ let ro = maybe 0 (\(VP _ x _ _) -> x) vp
+ line = show (row + ro + 1) ++ " "
+ padding = maxWidth - length line
+ attr = if currentRow == row + ro then withAttr attrCurrentLineNum else withAttr attrLineNum
+ render $ attr $ padLeft (Pad padding) $ str line
+
+getLexemes :: Text -> [Lexeme]
+getLexemes t = case tokenise t of
+ Left _ -> []
+ Right ls -> ls
+
+inLexeme :: Int -> [Lexeme] -> Maybe AttrName
+inLexeme i = strip <=< find (\(Located p _) -> contained p)
+ where
+ contained (SrcLoc (RealSrcLoc _ _ sc _ ec)) = sc - 1 <= i && i < ec - 1
+ contained _ = False
+ strip (Located _ x) = tokenToAttribute x
+
+tokenToAttribute :: Token -> Maybe AttrName
+tokenToAttribute (TextTok _) = Just syntaxText
+tokenToAttribute (NumberTok _) = Just syntaxNumber
+tokenToAttribute (OperatorTok _) = Just syntaxOperator
+tokenToAttribute (SpecialOperatorTok _) = Just syntaxOperator
+tokenToAttribute RestTok = Just syntaxSilence
+tokenToAttribute IfTok = Just syntaxKeyword
+tokenToAttribute ThenTok = Just syntaxKeyword
+tokenToAttribute ElseTok = Just syntaxKeyword
+tokenToAttribute LambdaTok = Just syntaxKeyword
+tokenToAttribute ArrowTok = Just syntaxKeyword
+tokenToAttribute DefineTok = Just syntaxKeyword
+tokenToAttribute DynamicDefineTok = Just syntaxKeyword
+tokenToAttribute TypeCommandTok = Just syntaxKeyword
+tokenToAttribute ShowCommandTok = Just syntaxKeyword
+tokenToAttribute InfoCommandTok = Just syntaxKeyword
+tokenToAttribute ResetShowConfigCommandTok = Just syntaxKeyword
+tokenToAttribute ResetEnvCommandTok = Just syntaxKeyword
+tokenToAttribute SetCommandTok = Just syntaxKeyword
+tokenToAttribute StatusCommandTok = Just syntaxKeyword
+tokenToAttribute EnvCommandTok = Just syntaxKeyword
+tokenToAttribute (LoadCommandTok _) = Just syntaxKeyword
+tokenToAttribute _ = Nothing
diff --git a/app/zwirnmill/Editor/Eval.hs b/app/zwirnmill/Editor/Eval.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Eval.hs
@@ -0,0 +1,69 @@
+{- HLINT ignore "Use tuple-section" -}
+
+module Editor.Eval where
+
+import Brick (EventM, get, modify)
+import Brick.BChan (BChan, writeBChan)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad.RWS (MonadIO (..))
+import Data.Functor (void)
+import qualified Data.Text as T
+import Editor.Core
+import Editor.Util (currentLine, getContent)
+import Lens.Micro
+import UI.Core (AppEvent (..), EditorEventEnv (..), Name, envEditorState, envEnv)
+import Zwirn.Language.Compiler (CIError (..), CompilerOutput (..), Environment, compilerInterpreterWithBlock, getBlockStartEnd, runCI)
+
+evalEvent :: EventM Name EditorEventEnv ()
+evalEvent = do
+ (EditorEventEnv chan _ _ _ env es) <- get
+ x <- liftIO $ evalCode es env
+ case x of
+ Left (CIError err env') -> do
+ modify $ \as -> as & envEnv .~ env'
+ block <- liftIO $ tryGetBlock es env
+ liftIO $ writeBChan chan (UpdateOutput (OutputError, show err))
+ liftIO $ clearFlash chan
+ modify $
+ envEditorState
+ %~ (esMessage ?~ show err)
+ . (esFlashBlock .~ ((\b -> (OutputError, b)) <$> block))
+ Right (OutMessage t, env', block) -> do
+ modify $ \as -> as & envEnv .~ env'
+ liftIO $ writeBChan chan (UpdateOutput (OutputInfo, T.unpack t))
+ liftIO $ clearFlash chan
+ liftIO $ writeBChan chan UpdateEnv
+ modify $
+ envEditorState
+ %~ (esMessage ?~ T.unpack t)
+ . (esFlashBlock ?~ (OutputInfo, block))
+ Right (_, env', block) -> do
+ modify $ \as -> as & envEnv .~ env'
+ liftIO $ writeBChan chan (UpdateOutput (OutputInfo, "Ok"))
+ liftIO $ clearFlash chan
+ liftIO $ writeBChan chan UpdateEnv
+ modify $
+ envEditorState
+ %~ (esMessage ?~ "Ok.")
+ . (esFlashBlock ?~ (OutputInfo, block))
+ where
+ clearFlash :: BChan AppEvent -> IO ()
+ clearFlash chan = void $ forkIO $ do
+ threadDelay 100000
+ writeBChan chan ClearFlash
+
+evalCode :: EditorState -> Environment -> IO (Either CIError (CompilerOutput, Environment, (Int, Int)))
+evalCode es env = runCI env (compilerInterpreterWithBlock r content)
+ where
+ content = getContent es
+ r = currentLine es
+
+tryGetBlock :: EditorState -> Environment -> IO (Maybe (Int, Int))
+tryGetBlock es env = do
+ x <- runCI env (getBlockStartEnd r content)
+ case x of
+ Left _ -> return Nothing
+ Right block -> return $ Just block
+ where
+ content = getContent es
+ r = currentLine es
diff --git a/app/zwirnmill/Editor/Event.hs b/app/zwirnmill/Editor/Event.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Event.hs
@@ -0,0 +1,100 @@
+{- HLINT ignore "Use tuple-section" -}
+module Editor.Event where
+
+import Brick hiding (on)
+import Brick.Keybindings
+import Editor.Core
+import Editor.Cursor
+import Editor.Diagnostic (diagnoseEvent)
+import Editor.Eval
+import Editor.File
+import Editor.Insertion
+import Editor.Keymap (EditorAction (..))
+import Editor.Line
+import Editor.Popup
+import Editor.Selection
+import Editor.Undo
+import Editor.Util
+import qualified Graphics.Vty as V
+import Keymap (kEditor)
+import Lens.Micro
+import Lens.Micro.Extras (view)
+import UI.Core hiding (Copy)
+
+editorToAppEvent :: Name -> EditorState -> BrickEvent Name AppEvent -> EventM Name AppState EditorState
+editorToAppEvent name es ev = do
+ env <- gets asEnvironment
+ chan <- gets asChan
+ vtyOut <- gets asVtyOutput
+ kc <- gets asKeyConfig
+ (EditorEventEnv _ _ _ _ env' es') <- nestEventM' (EditorEventEnv chan name kc vtyOut env es) (handleEditorEvent ev)
+ modify (\as -> as {asEnvironment = env'})
+ return es'
+
+handleEditorEvent :: BrickEvent Name AppEvent -> EventM Name EditorEventEnv ()
+handleEditorEvent (VtyEvent (V.EvKey key mods)) = do
+ withEditorEvent clearPopup
+ handleEditorKeyEvent key mods
+ diagnoseEvent
+handleEditorEvent (MouseDown (EditorViewport i) V.BScrollUp _ _) = vScrollBy (viewportScroll (EditorViewport i)) (-1)
+handleEditorEvent (MouseDown (Editor i) V.BScrollUp _ _) = vScrollBy (viewportScroll (EditorViewport i)) (-1)
+handleEditorEvent (MouseDown (EditorViewport i) V.BScrollDown _ _) = vScrollBy (viewportScroll (EditorViewport i)) 1
+handleEditorEvent (MouseDown (Editor i) V.BScrollDown _ _) = vScrollBy (viewportScroll (EditorViewport i)) 1
+handleEditorEvent (VtyEvent (V.EvPaste x)) = diagnoseEvent >> withEditorEvent (pasteContent x)
+handleEditorEvent (AppEvent ClearFlash) = withEditorEvent clearFlashBlock
+handleEditorEvent (AppEvent (FileSelected Nothing)) = return ()
+handleEditorEvent (AppEvent (FileSelected (Just path))) = loadEvent path
+handleEditorEvent _ = return ()
+
+handleEditorKeyEvent :: V.Key -> [V.Modifier] -> EventM Name EditorEventEnv ()
+handleEditorKeyEvent key mods = do
+ kc <- gets (view envKeyConfig)
+ handled <- handleKey (editorKeyDispatcher $ kEditor kc) key mods
+ if handled
+ then return ()
+ else case (key, mods) of
+ (V.KChar c, []) -> modify $ envEditorState %~ insertChar c . clearMessage
+ _ -> return ()
+
+withEditorEvent :: (EditorState -> EditorState) -> EventM Name EditorEventEnv ()
+withEditorEvent f = modify $ envEditorState %~ f
+
+editorKeyEventHandler :: [KeyEventHandler EditorAction (EventM Name EditorEventEnv)]
+editorKeyEventHandler =
+ [ onEvent Save "save file" saveEvent,
+ onEvent Eval "evaluate block" evalEvent,
+ onEvent Open "open file" openEvent,
+ onEvent Copy "copy selection" copyEvent,
+ onEvent Hint "show hint popup" hintEvent,
+ onEvent ExitHint "close hint popup" (withEditorEvent clearPopup),
+ onEvent Undo "undo" (withEditorEvent undo),
+ onEvent Redo "redo" (withEditorEvent redo),
+ onEvent CommentLine "toggle comment" (withEditorEvent $ toggleCommentCurrentLine "--"),
+ onEvent SwapLineUp "swap line up" (withEditorEvent swapLineUp),
+ onEvent SwapLineDown "swap line down" (withEditorEvent swapLineDown),
+ onEvent DuplicateLine "duplicate line" (withEditorEvent duplicateCurrentLine),
+ onEvent DeleteLine "delete line" (withEditorEvent deleteCurrentLine),
+ onEvent DeleteChar "delete character" (withEditorEvent deleteCharForward),
+ onEvent DeleteCharBack "delete character" (withEditorEvent deleteCharBack),
+ onEvent SelectAll "select all" (withEditorEvent selectAll),
+ onEvent MoveUp "move cursor up" (withEditorEvent moveCursorUp),
+ onEvent MoveDown "move cursor down" (withEditorEvent moveCursorDown),
+ onEvent MoveLeft "move cursor left" (withEditorEvent moveCursorLeft),
+ onEvent MoveRight "move cursor right" (withEditorEvent moveCursorRight),
+ onEvent MoveLineStart "move cursor line start" (withEditorEvent moveCursorLineStart),
+ onEvent MoveLineEnd "move cursor line end" (withEditorEvent moveCursorLineEnd),
+ onEvent MoveFileStart "move cursor file start" (withEditorEvent moveCursorFileStart),
+ onEvent MoveFileEnd "move cursor file end" (withEditorEvent moveCursorFileEnd),
+ onEvent MoveWordLeft "move cursor word left" (withEditorEvent moveCursorWordLeft),
+ onEvent MoveWordRight "move cursor word left" (withEditorEvent moveCursorWordRight),
+ onEvent NewLine "new line" (withEditorEvent insertNewline),
+ onEvent ExtendSelectionUp "extend selection up" (withEditorEvent extendSelectionUp),
+ onEvent ExtendSelectionDown "extend selection down" (withEditorEvent extendSelectionDown),
+ onEvent ExtendSelectionLeft "extend selection left" (withEditorEvent extendSelectionLeft),
+ onEvent ExtendSelectionRight "extend selection right" (withEditorEvent extendSelectionRight)
+ ]
+
+editorKeyDispatcher :: KeyConfig EditorAction -> KeyDispatcher EditorAction (EventM Name EditorEventEnv)
+editorKeyDispatcher conf = case keyDispatcher conf editorKeyEventHandler of
+ Left kb -> error $ "conflicting keybindings: " <> show (map fst kb)
+ Right dis -> dis
diff --git a/app/zwirnmill/Editor/File.hs b/app/zwirnmill/Editor/File.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/File.hs
@@ -0,0 +1,95 @@
+module Editor.File where
+
+import Brick hiding (on)
+import Brick.BChan (writeBChan)
+import Control.Concurrent (forkIO)
+import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Base64.Types as B64
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as B64
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Editor.Selection
+import Editor.Util
+import Graphics.UI.TinyFileDialogs (openFileDialog, saveFileDialog)
+import qualified Graphics.Vty as V
+import Lens.Micro
+import Lens.Micro.Extras
+import UI.Core
+
+saveEvent :: EventM Name EditorEventEnv ()
+saveEvent = do
+ result <- gets (view envEditorState) >>= liftIO . saveFile
+ case result of
+ Right es' -> modify $ envEditorState .~ es'
+ Left msg -> modify $ envEditorState %~ setMessage msg
+
+openEvent :: EventM Name EditorEventEnv ()
+openEvent = do
+ chan <- gets (view envBChan)
+ void $ liftIO $ forkIO $ do
+ mPath <- openFile
+ writeBChan chan (FileSelected mPath)
+
+copyEvent :: EventM Name EditorEventEnv ()
+copyEvent = do
+ es <- gets (view envEditorState)
+ vtyOut <- gets (view envVtyOut)
+ case selectedText es of
+ Nothing -> return ()
+ Just t -> case vtyOut of
+ Nothing -> return ()
+ Just out -> do
+ liftIO (copyToClipboard out t)
+ modify $ envEditorState %~ setMessage "Copied."
+
+loadEvent :: FilePath -> EventM Name EditorEventEnv ()
+loadEvent path = do
+ contents <- liftIO (readFile path)
+ modify $ envEditorState .~ loadFile path (T.pack contents)
+
+saveFile :: EditorState -> IO (Either String EditorState)
+saveFile es =
+ case es ^. esFilePath of
+ Nothing -> do
+ mpath <- saveFileDialog "save file" "untitled.zwirn" ["*.zwirn"] "zwirn files"
+ case mpath of
+ Nothing -> return $ Left "Failed to get path"
+ Just path -> do
+ writeFile (T.unpack path) (T.unpack content)
+ return $
+ Right $
+ es
+ & esUnsaved .~ False
+ & esMessage ?~ "Saved."
+ & esFilePath ?~ T.unpack path
+ Just path -> do
+ writeFile path (T.unpack content)
+ return $ Right $ es & esUnsaved .~ False & esMessage ?~ "Saved."
+ where
+ content = getContent es
+
+loadFile :: FilePath -> Text -> EditorState
+loadFile path contents =
+ let ls = T.lines contents
+ in newEditor
+ & esZipper .~ Z.textZipper ls Nothing
+ & esFilePath ?~ path
+ & esUnsaved .~ False
+
+openFile :: IO (Maybe FilePath)
+openFile = fmap T.unpack . safeHead <$> openFileDialog "choose a zwirn file" "untitled.zwirn" ["*.zwirn"] "zwirn files" False
+ where
+ safeHead (Just (x : _)) = Just x
+ safeHead _ = Nothing
+
+copyToClipboard :: V.Output -> Text -> IO ()
+copyToClipboard output text = V.outputByteBuffer output osc52
+ where
+ textBytes = TE.encodeUtf8 text
+ b64Bytes = B64.extractBase64 $ B64.encodeBase64' textBytes
+ osc52 = B.concat ["\ESC]52;c;", b64Bytes, "\BEL"]
diff --git a/app/zwirnmill/Editor/Insertion.hs b/app/zwirnmill/Editor/Insertion.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Insertion.hs
@@ -0,0 +1,56 @@
+module Editor.Insertion where
+
+import Brick.Widgets.Edit (decodeUtf8)
+import qualified Data.ByteString as B
+import Data.Char (isSpace)
+import qualified Data.Text as T
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Editor.Selection
+import Editor.Undo (pushUndo)
+import Editor.Util
+import Lens.Micro
+
+insertChar :: Char -> EditorState -> EditorState
+insertChar '\t' es = withZipper (Z.insertMany $ T.replicate tw " ") (deleteSelection $ pushUndo es)
+ where
+ tw = es ^. esTabWidth
+insertChar '[' es = case getSelectionRange es of
+ Nothing -> withZipper (\z -> if maybe True (== ' ') $ Z.currentChar z then Z.moveLeft $ Z.insertMany "[]" z else Z.insertChar '[' z) (deleteSelection $ pushUndo es)
+ Just (star, (er, ec)) -> withZipper (Z.moveCursorClosest (currentCursor es) . Z.insertChar ']' . Z.moveCursorClosest (er, ec + 2) . Z.insertChar '[' . Z.moveCursorClosest star) (pushUndo es)
+insertChar '(' es = case getSelectionRange es of
+ Nothing -> withZipper (\z -> if maybe True (== ' ') $ Z.currentChar z then Z.moveLeft $ Z.insertMany "()" z else Z.insertChar '(' z) (deleteSelection $ pushUndo es)
+ Just (star, (er, ec)) -> withZipper (Z.moveCursorClosest (currentCursor es) . Z.insertChar ')' . Z.moveCursorClosest (er, ec + 2) . Z.insertChar '(' . Z.moveCursorClosest star) (pushUndo es)
+insertChar '"' es = case getSelectionRange es of
+ Nothing -> withZipper (\z -> if maybe True (== ' ') $ Z.currentChar z then Z.moveLeft $ Z.insertMany "\"\"" z else Z.insertChar '"' z) (deleteSelection $ pushUndo es)
+ Just (star, (er, ec)) -> withZipper (Z.moveCursorClosest (currentCursor es) . Z.insertChar '"' . Z.moveCursorClosest (er, ec + 2) . Z.insertChar '"' . Z.moveCursorClosest star) (pushUndo es)
+insertChar ch es = withZipper (Z.insertChar ch) (deleteSelection $ pushUndo es)
+
+insertNewline :: EditorState -> EditorState
+insertNewline = withZipper z . deleteSelection . pushUndo
+ where
+ z x = Z.insertMany (T.replicate l " ") $ Z.breakLine x
+ where
+ cur = Z.currentLine x
+ l = T.length $ T.takeWhile isSpace cur
+
+deleteCharForward :: EditorState -> EditorState
+deleteCharForward es
+ | hasSelection es = deleteSelection $ pushUndo es
+ | otherwise = withZipper Z.deleteChar $ pushUndo es
+
+deleteCharBack :: EditorState -> EditorState
+deleteCharBack es
+ | hasSelection es = deleteSelection $ pushUndo es
+ | Z.currentChar (es ^. esZipper) == Just ']' && Z.currentChar (Z.moveLeft $ es ^. esZipper) == Just '[' = withZipper (Z.deletePrevChar . Z.deleteChar) $ pushUndo es
+ | Z.currentChar (es ^. esZipper) == Just ')' && Z.currentChar (Z.moveLeft $ es ^. esZipper) == Just '(' = withZipper (Z.deletePrevChar . Z.deleteChar) $ pushUndo es
+ | Z.currentChar (es ^. esZipper) == Just '"' && Z.currentChar (Z.moveLeft $ es ^. esZipper) == Just '"' = withZipper (Z.deletePrevChar . Z.deleteChar) $ pushUndo es
+ | otherwise = withZipper Z.deletePrevChar $ pushUndo es
+
+deleteCurrentLine :: EditorState -> EditorState
+deleteCurrentLine = withZipper (Z.killToBOL . Z.killToEOL) . deleteSelection . pushUndo
+
+pasteContent :: B.ByteString -> EditorState -> EditorState
+pasteContent cont es = case decodeUtf8 cont of
+ Left _ -> es
+ Right decoded -> withZipper (Z.insertMany decoded) $ deleteSelection $ pushUndo es
diff --git a/app/zwirnmill/Editor/Keymap.hs b/app/zwirnmill/Editor/Keymap.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Keymap.hs
@@ -0,0 +1,117 @@
+module Editor.Keymap where
+
+import Brick.Keybindings
+import Data.List (groupBy)
+import qualified Graphics.Vty as V
+
+data EditorAction
+ = Save
+ | Open
+ | Undo
+ | Redo
+ | Copy
+ | Hint
+ | ExitHint
+ | Eval
+ | CommentLine
+ | SwapLineUp
+ | SwapLineDown
+ | DuplicateLine
+ | DeleteLine
+ | SelectAll
+ | NewLine
+ | DeleteChar
+ | DeleteCharBack
+ | MoveUp
+ | MoveDown
+ | MoveLeft
+ | MoveRight
+ | MoveLineStart
+ | MoveLineEnd
+ | MoveFileStart
+ | MoveFileEnd
+ | MoveWordLeft
+ | MoveWordRight
+ | ExtendSelectionUp
+ | ExtendSelectionDown
+ | ExtendSelectionLeft
+ | ExtendSelectionRight
+ deriving (Show, Eq, Ord)
+
+defaultEditorBindings :: [(EditorAction, [Binding])]
+defaultEditorBindings =
+ [ (Save, [ctrl 's']),
+ (Open, [ctrl 'o']),
+ (Copy, [ctrl 'c']),
+ (Hint, [ctrl '@']),
+ (ExitHint, [bind V.KEsc]),
+ (Eval, [ctrl V.KEnter, meta V.KEnter]),
+ (Undo, [ctrl 'z']),
+ (Redo, [ctrl 'y']),
+ (CommentLine, [ctrl '/', ctrl '_']),
+ (SwapLineUp, [meta V.KUp]),
+ (SwapLineDown, [meta V.KDown]),
+ (DuplicateLine, [ctrl 'd']),
+ (DeleteLine, [ctrl 'k']),
+ (MoveUp, [bind V.KUp]),
+ (MoveDown, [bind V.KDown]),
+ (MoveLeft, [bind V.KLeft]),
+ (MoveRight, [bind V.KRight]),
+ (MoveLineStart, [bind V.KHome]),
+ (MoveLineEnd, [bind V.KEnd]),
+ (NewLine, [bind V.KEnter]),
+ (DeleteChar, [bind V.KDel]),
+ (DeleteCharBack, [bind V.KBS]),
+ (MoveFileStart, [ctrl V.KHome]),
+ (MoveFileEnd, [ctrl V.KEnd]),
+ (MoveWordLeft, [ctrl V.KLeft]),
+ (MoveWordRight, [ctrl V.KRight]),
+ (ExtendSelectionUp, [shift V.KUp]),
+ (ExtendSelectionDown, [shift V.KDown]),
+ (ExtendSelectionLeft, [shift V.KLeft]),
+ (ExtendSelectionRight, [shift V.KRight]),
+ (SelectAll, [ctrl 'a'])
+ ]
+
+editorKeyEvents :: KeyEvents EditorAction
+editorKeyEvents =
+ keyEvents
+ [ ("save", Save),
+ ("open", Open),
+ ("undo", Undo),
+ ("redo", Redo),
+ ("copy", Copy),
+ ("hint", Hint),
+ ("exithint", ExitHint),
+ ("eval", Eval),
+ ("comment", CommentLine),
+ ("swapup", SwapLineUp),
+ ("swapdown", SwapLineDown),
+ ("duplicate", DuplicateLine),
+ ("deleteline", DeleteLine),
+ ("selectall", SelectAll),
+ ("newline", NewLine),
+ ("delete", DeleteChar),
+ ("deleteback", DeleteCharBack),
+ ("up", MoveUp),
+ ("down", MoveDown),
+ ("left", MoveLeft),
+ ("right", MoveRight),
+ ("linestart", MoveLineStart),
+ ("lineend", MoveLineEnd),
+ ("fileend", MoveFileEnd),
+ ("filestart", MoveFileStart),
+ ("wordleft", MoveWordLeft),
+ ("wordright", MoveWordRight),
+ ("extendup", ExtendSelectionUp),
+ ("extenddown", ExtendSelectionDown),
+ ("extendleft", ExtendSelectionLeft),
+ ("extendright", ExtendSelectionRight)
+ ]
+
+editorKeyConfigWithUserConfig :: [(Binding, EditorAction)] -> KeyConfig EditorAction
+editorKeyConfigWithUserConfig conf = newKeyConfig editorKeyEvents defaultEditorBindings conf'
+ where
+ conf' = map toBinding $ groupBy (\(_, a1) (_, a2) -> a1 == a2) conf
+ toBinding [] = error "Error in toBinding"
+ toBinding ((b, a) : bs) = (a, BindingList $ b : map fst bs)
diff --git a/app/zwirnmill/Editor/Line.hs b/app/zwirnmill/Editor/Line.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Line.hs
@@ -0,0 +1,88 @@
+module Editor.Line where
+
+import Data.Char
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Editor.Undo
+import Editor.Util
+import Lens.Micro
+
+replaceCurrentLine :: Text -> Z.TextZipper Text -> Z.TextZipper Text
+replaceCurrentLine x z = case Z.currentLine z of
+ "" -> Z.insertMany x z
+ _ -> Z.killToEOL $ Z.insertMany x $ Z.killToBOL z
+
+duplicateCurrentLine :: EditorState -> EditorState
+duplicateCurrentLine = withZipper z . clearSelection . pushUndo
+ where
+ z x = Z.moveCursorClosest (r + 1, c) $ Z.insertMany currentText withNewline
+ where
+ currentText = Z.currentLine x
+ (r, c) = Z.cursorPosition x
+ withNewline = Z.insertChar '\n' $ Z.gotoEOL x
+
+swapLineUp :: EditorState -> EditorState
+swapLineUp = withZipper z . clearSelection . pushUndo
+ where
+ z x = Z.moveCursorClosest (r - 1, c) $ replaceCurrentLine replaceText $ Z.moveUp $ replaceCurrentLine upperText x
+ where
+ (r, c) = Z.cursorPosition x
+ currentText = Z.currentLine x
+ upperText = Z.currentLine (Z.moveUp x)
+ replaceText
+ | T.null currentText && T.null upperText = ""
+ | T.null currentText = "\n"
+ | otherwise = currentText
+
+swapLineDown :: EditorState -> EditorState
+swapLineDown = withZipper z . clearSelection . pushUndo
+ where
+ z x = Z.moveCursorClosest (r + 1, c) $ replaceCurrentLine replaceText $ Z.moveDown $ replaceCurrentLine lowerText x
+ where
+ (r, c) = Z.cursorPosition x
+ currentText = Z.currentLine x
+ lowerText = Z.currentLine (Z.moveDown x)
+ replaceText
+ | T.null currentText && T.null lowerText = ""
+ | T.null currentText = "\n"
+ | otherwise = currentText
+
+toggleCommentCurrentLine :: Text -> EditorState -> EditorState
+toggleCommentCurrentLine prefix = withZipper func
+ where
+ func z = case deletePrefix prefix $ moveFirstWordStart z of
+ (z', True) -> Z.moveCursor (r, c - l) $ (if Just ' ' == Z.currentChar z' then Z.deleteChar else id) z'
+ (z', False) -> Z.moveCursor (r, c + l) $ Z.insertMany (prefix <> " ") z'
+ where
+ l = T.length $ prefix <> " "
+ (r, c) = Z.cursorPosition z
+
+moveFirstWordStart :: Z.TextZipper Text -> Z.TextZipper Text
+moveFirstWordStart z = go $ Z.gotoBOL z
+ where
+ go x = case Z.currentChar x of
+ Nothing -> x
+ Just c -> if isSpace c then go $ Z.moveRight x else x
+
+deletePrefix :: Text -> Z.TextZipper Text -> (Z.TextZipper Text, Bool)
+deletePrefix prefix z = T.foldl func (z, True) prefix
+ where
+ func (_, False) _ = (z, False)
+ func (x, True) c = case Z.currentChar x of
+ Nothing -> (z, False)
+ (Just c') -> (if c == c' then Z.deleteChar x else z, c == c')
+
+unindentCurrentLine :: EditorState -> EditorState
+unindentCurrentLine es = withZipper z $ clearSelection $ pushUndo es
+ where
+ z x = Z.moveCursor (r, c - tw) dropped
+ where
+ dropped = dropN tw isSpace $ Z.gotoBOL x
+ tw = es ^. esTabWidth
+ (r, c) = Z.cursorPosition x
+ dropN 0 _ zi = zi
+ dropN i f zi = case Z.currentChar zi of
+ Nothing -> zi
+ Just cc -> if f cc then dropN (i - 1) f $ Z.deleteChar zi else zi
diff --git a/app/zwirnmill/Editor/Popup.hs b/app/zwirnmill/Editor/Popup.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Popup.hs
@@ -0,0 +1,54 @@
+module Editor.Popup where
+
+import Brick (Viewport (..), get, modify)
+import Brick.Main (lookupViewport)
+import Brick.Types (EventM)
+import Control.Monad.RWS (MonadIO (..))
+import qualified Data.Text as T
+import Editor.Core
+import Editor.Diagnostic
+import Editor.Util
+import Lens.Micro
+import UI.Core (EditorEventEnv (..), Name (..), envEditorState)
+import Zwirn.Language.Compiler (CIError, Environment, runCI)
+import Zwirn.Language.LSP.Hover (parseAndGetInfoAt)
+import Zwirn.Language.Location (Position (..), RealSrcLoc (..))
+
+hintEvent :: EventM Name EditorEventEnv ()
+hintEvent = do
+ let fromName (Editor i) = EditorViewport i
+ fromName x = x
+ (EditorEventEnv _ name _ _ env es) <- get
+ off <- maybe (0, 0) (\(VP l r _ _) -> (l, r)) <$> lookupViewport (fromName name)
+ es' <- liftIO $ getPopup es env off
+ modify $ envEditorState .~ es'
+ return ()
+
+getPopupInfo :: EditorState -> Environment -> IO (Either CIError (Maybe (T.Text, RealSrcLoc)))
+getPopupInfo es env = runCI env (parseAndGetInfoAt False content (Position r (c + 1)))
+ where
+ content = getContent es
+ (r, c) = currentCursor es
+
+getPopup :: EditorState -> Environment -> (Int, Int) -> IO EditorState
+getPopup es env (left, ro) = do
+ res <- getPopupInfo es env
+ ds <- getDiagnostics es env
+
+ let cursor = currentCursor es
+ mdiag = getAnyDiagnostic cursor $ rowDiagnostics (fst $ currentCursor es) ds
+ mpopup = case mdiag of
+ Just (Diagnostic (pos, _) diag) -> Just (diag, pos)
+ Nothing -> case res of
+ Right (Just (info, pos)) -> Just (T.unpack info, (rStartLine pos, rStartChar pos))
+ _ -> Nothing
+
+ case mpopup of
+ (Just (cont, pos)) -> return $ es & esPopup ?~ Popup cont (screenCol, popupRow) -- {esPopup = Just $ Popup cont (screenCol, popupRow)}
+ where
+ infoWidth = length $ lines cont
+ -- visRow = esScrollRow es
+ screenCol = snd pos + lineNumberWidth es - left
+ row = fst pos - ro
+ popupRow = if row - (infoWidth + 2) < 0 then row + 1 else row - (infoWidth + 2)
+ _ -> return $ clearPopup es
diff --git a/app/zwirnmill/Editor/Selection.hs b/app/zwirnmill/Editor/Selection.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Selection.hs
@@ -0,0 +1,90 @@
+module Editor.Selection where
+
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Editor.Util
+import Lens.Micro
+
+getSelectionRange :: EditorState -> Maybe ((Int, Int), (Int, Int))
+getSelectionRange es = getSelectionOrdered (currentCursor es) (es ^. esSelection)
+
+getSelectionOrdered :: (Int, Int) -> Maybe (Int, Int) -> Maybe ((Int, Int), (Int, Int))
+getSelectionOrdered cursor msel = normaliseSelection cursor <$> msel
+ where
+ normaliseSelection (r1, c1) (r2, c2)
+ | r1 < r2 = ((r1, c1), (r2, c2))
+ | r1 == r2 && c1 <= c2 = ((r1, c1), (r2, c2))
+ | otherwise = ((r2, c2), (r1, c1 - 1))
+
+inSelection :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int) -> Bool
+inSelection (a, b) cursor msel = case getSelectionOrdered cursor msel of
+ Nothing -> False
+ Just (x, y) -> inSpan (a, b) x y
+
+deleteSelection :: EditorState -> EditorState
+deleteSelection es = case getSelectionRange es of
+ Nothing -> es
+ Just (p, end) -> clearSelection $ es & esZipper .~ final
+ where
+ z = es ^. esZipper
+ movedZ = Z.moveCursor p z
+ charCount = totalCharsBetween movedZ end + 1
+ final = iterate Z.deleteChar movedZ !! charCount
+
+totalCharsBetween :: Z.TextZipper Text -> (Int, Int) -> Int
+totalCharsBetween tz target = go 0 tz
+ where
+ go count currentTz
+ | Z.cursorPosition currentTz == target = count
+ | currentTz == Z.moveRight currentTz = count
+ | otherwise = go (count + 1) (Z.moveRight currentTz)
+
+selectedText :: EditorState -> Maybe Text
+selectedText es = case getSelectionRange es of
+ Nothing -> Nothing
+ Just (begin, end) -> Just $ fst $ go ("", Z.moveCursor begin $ es ^. esZipper)
+ where
+ go (accum, z)
+ | Z.cursorPosition z == end = (T.reverse (T.cons c accum), z)
+ | otherwise = go (T.cons c accum, Z.moveRight z)
+ where
+ c = fromMaybe '\n' (Z.currentChar z)
+
+extendSelection :: (Z.TextZipper Text -> Z.TextZipper Text) -> EditorState -> EditorState
+extendSelection f es =
+ let es' = withZipper f es
+ cursor = currentCursor es
+ next = currentCursor es'
+ actual = if fst cursor > fst next || snd next < snd cursor then (fst cursor, snd cursor - 1) else cursor
+ anchor = fromMaybe actual (es' ^. esSelection)
+ in es' & esSelection ?~ anchor
+
+extendSelectionUp :: EditorState -> EditorState
+extendSelectionUp = extendSelection Z.moveUp
+
+extendSelectionDown :: EditorState -> EditorState
+extendSelectionDown = extendSelection Z.moveDown
+
+extendSelectionLeft :: EditorState -> EditorState
+extendSelectionLeft = extendSelection Z.moveLeft
+
+extendSelectionRight :: EditorState -> EditorState
+extendSelectionRight = extendSelection Z.moveRight
+
+extendSelectionLineStart :: EditorState -> EditorState
+extendSelectionLineStart = extendSelection Z.gotoBOL
+
+extendSelectionLineEnd :: EditorState -> EditorState
+extendSelectionLineEnd = extendSelection Z.gotoEOL
+
+extendSelectionTo :: (Int, Int) -> EditorState -> EditorState
+extendSelectionTo p = extendSelection (Z.moveCursor p)
+
+selectAll :: EditorState -> EditorState
+selectAll es =
+ es
+ & esZipper %~ Z.gotoEOF
+ & esSelection ?~ (0, 0)
diff --git a/app/zwirnmill/Editor/Undo.hs b/app/zwirnmill/Editor/Undo.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Undo.hs
@@ -0,0 +1,38 @@
+module Editor.Undo where
+
+import Editor.Core
+import Editor.Util
+import Lens.Micro
+
+pushUndo :: EditorState -> EditorState
+pushUndo es =
+ let entry = UndoEntry (es ^. esZipper) (es ^. esSelection)
+ in es
+ & esUndoStack %~ (entry :) . take 200
+ & esRedoStack .~ []
+ & esUnsaved .~ True
+
+undo :: EditorState -> EditorState
+undo es = case es ^. esUndoStack of
+ [] -> clearSelection $ setMessage "Nothing to undo." es
+ (e : rest) ->
+ let redoEntry = UndoEntry (es ^. esZipper) (es ^. esSelection)
+ in es
+ & esZipper .~ undoZipper e
+ & esUndoStack .~ rest
+ & esRedoStack %~ (redoEntry :)
+ & esSelection .~ undoSelection e
+ & esUnsaved .~ True
+ & esMessage ?~ "Undo."
+
+redo :: EditorState -> EditorState
+redo es = case es ^. esRedoStack of
+ [] -> setMessage "Nothing to redo." es
+ (e : rest) ->
+ let undoEntry = UndoEntry (es ^. esZipper) (es ^. esSelection)
+ in es
+ & esRedoStack .~ rest
+ & esUndoStack %~ (undoEntry :)
+ & esSelection .~ undoSelection e
+ & esUnsaved .~ True
+ & esMessage ?~ "Redo."
diff --git a/app/zwirnmill/Editor/Util.hs b/app/zwirnmill/Editor/Util.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Editor/Util.hs
@@ -0,0 +1,61 @@
+module Editor.Util where
+
+import Data.Maybe (isJust)
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Zipper as Z
+import Editor.Core
+import Lens.Micro ((%~), (.~), (?~), (^.))
+import Lens.Micro.Extras (view)
+
+withZipper :: (Z.TextZipper Text -> Z.TextZipper Text) -> EditorState -> EditorState
+withZipper f = esZipper %~ f
+
+hasSelection :: EditorState -> Bool
+hasSelection = isJust . view esSelection
+
+getContent :: EditorState -> Text
+getContent es = T.intercalate "\n" $ Z.getText $ es ^. esZipper
+
+getLines :: EditorState -> [Text]
+getLines es = Z.getText $ es ^. esZipper
+
+getLongestLine :: EditorState -> Int
+getLongestLine es = maximum $ map T.length $ getLines es
+
+lineNumberWidth :: EditorState -> Int
+lineNumberWidth es = length (show (lineCount es)) + 1
+
+lineCount :: EditorState -> Int
+lineCount = length . Z.getText . view esZipper
+
+currentLine :: EditorState -> Int
+currentLine = fst . Z.cursorPosition . view esZipper
+
+currentLineText :: EditorState -> Text
+currentLineText = Z.currentLine . view esZipper
+
+currentCursor :: EditorState -> (Int, Int)
+currentCursor = Z.cursorPosition . view esZipper
+
+clearSelection :: EditorState -> EditorState
+clearSelection = esSelection .~ Nothing
+
+clearPopup :: EditorState -> EditorState
+clearPopup = esPopup .~ Nothing
+
+clearFlashBlock :: EditorState -> EditorState
+clearFlashBlock = esFlashBlock .~ Nothing
+
+clearMessage :: EditorState -> EditorState
+clearMessage = esMessage .~ Nothing
+
+setMessage :: String -> EditorState -> EditorState
+setMessage msg = esMessage ?~ msg
+
+inSpan :: (Ord a1, Ord a2) => (a2, a1) -> (a2, a1) -> (a2, a1) -> Bool
+inSpan (a, b) (srs, scs) (sre, sce)
+ | a == srs && a == sre = scs <= b && b <= sce
+ | a == srs = b >= scs
+ | a == sre = b <= sce
+ | otherwise = a > srs && a < sre
diff --git a/app/zwirnmill/EnvBrowser/Draw.hs b/app/zwirnmill/EnvBrowser/Draw.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/EnvBrowser/Draw.hs
@@ -0,0 +1,19 @@
+module EnvBrowser.Draw where
+
+import Brick (ViewportType (..), Widget)
+import Brick.Widgets.Core
+import qualified Data.Text as T
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import UI.Core (EnvBrowser (..), Name (..))
+
+drawEnvBrowser :: (Int, Int) -> EnvBrowser -> Widget Name
+drawEnvBrowser (sx, _) (EnvB search cont) = vBox [txt ("search: " <> search), txt $ T.replicate sx "━", viewport EnvBrowserViewport Vertical $ drawEnv search cont]
+
+drawEnv :: T.Text -> Vector T.Text -> Widget Name
+drawEnv search ss = vBox $ map drawEntry (V.toList fs)
+ where
+ fs = V.filter (T.isPrefixOf (T.toLower search) . T.toLower) ss
+
+drawEntry :: T.Text -> Widget Name
+drawEntry = txt
diff --git a/app/zwirnmill/EnvBrowser/Event.hs b/app/zwirnmill/EnvBrowser/Event.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/EnvBrowser/Event.hs
@@ -0,0 +1,34 @@
+module EnvBrowser.Event where
+
+import Brick (BrickEvent (..), EventM, modify, vScrollBy, viewportScroll)
+import Brick.Types (gets)
+import Control.Monad (when)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Graphics.Vty as V
+import UI.Core (AppState (..), Content (..), EnvBrowser (..), Name (..), Window (..))
+import Zwirn.Language.Compiler (Environment (..))
+import Zwirn.Language.Environment (InterpreterEnv (..))
+
+handleEnvBrowserEvent :: EnvBrowser -> BrickEvent Name e -> EventM Name AppState EnvBrowser
+handleEnvBrowserEvent s (VtyEvent (V.EvKey (V.KChar '\t') _)) = return s
+handleEnvBrowserEvent (EnvB search vs) (VtyEvent (V.EvKey (V.KChar x) _)) = return (EnvB (T.snoc search x) vs)
+handleEnvBrowserEvent (EnvB search vs) (VtyEvent (V.EvKey V.KBS _)) = case T.unsnoc search of
+ Just (rest, _) -> return (EnvB rest vs)
+ Nothing -> return (EnvB T.empty vs)
+handleEnvBrowserEvent s (MouseDown name V.BScrollUp _ _) = when (isEnv name) (vScrollBy (viewportScroll EnvBrowserViewport) (-1)) >> return s
+handleEnvBrowserEvent s (MouseDown name V.BScrollDown _ _) = when (isEnv name) (vScrollBy (viewportScroll EnvBrowserViewport) 1) >> return s
+handleEnvBrowserEvent s _ = return s
+
+isEnv :: Name -> Bool
+isEnv EnvBrowser = True
+isEnv EnvBrowserViewport = True
+isEnv _ = False
+
+updateEnvBrowser :: EventM Name AppState ()
+updateEnvBrowser = do
+ newenv <- gets $ V.fromList . Map.keys . eExpressions . intEnv . asEnvironment
+ let alt (Just (Window x y (EnvBrowserContent (EnvB search _)) z l)) = Just $ Window x y (EnvBrowserContent $ EnvB search newenv) z l
+ alt _ = Nothing
+ modify $ \as -> as {asWindows = Map.alter alt EnvBrowser $ asWindows as}
diff --git a/app/zwirnmill/Keyboard/Draw.hs b/app/zwirnmill/Keyboard/Draw.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Keyboard/Draw.hs
@@ -0,0 +1,8 @@
+module Keyboard.Draw where
+
+import Brick (Widget, fill, hBox, txt, vBox)
+import UI.Core (Keyboard (..), Name)
+
+drawKeyboard :: (Int, Int) -> Keyboard -> Widget Name
+drawKeyboard (sx, _) (KeyB (Just sd)) = vBox (hBox [txt $ "keyboard: " <> sd, fill ' '] : replicate (sx - 1) (fill ' '))
+drawKeyboard (sx, _) (KeyB Nothing) = vBox (hBox [txt "Please select an action"] : replicate (sx - 1) (fill ' '))
diff --git a/app/zwirnmill/Keyboard/Event.hs b/app/zwirnmill/Keyboard/Event.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Keyboard/Event.hs
@@ -0,0 +1,49 @@
+module Keyboard.Event where
+
+import Brick (BrickEvent (..), EventM, gets, modify)
+import Control.Monad.IO.Class (MonadIO (..))
+import Data.List (elemIndex)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Graphics.UI.TinyFileDialogs (inputBox)
+import qualified Graphics.Vty as V
+import UI.Core (AppState (..), Content (..), Keyboard (..), Name (..), Window (..))
+import Zwirn.Language.Compiler (Environment, compilerInterpreterWithBlock, runCI)
+
+handleKeyboardEvent :: Keyboard -> BrickEvent Name e -> EventM Name AppState Keyboard
+handleKeyboardEvent k (VtyEvent (V.EvKey (V.KChar c) _)) = keyboardAction k c >> return k
+handleKeyboardEvent k _ = return k
+
+jankoMidi :: Char -> Maybe Int
+jankoMidi c
+ | c `elem` row1 = lookupIndex c row1 58
+ | c `elem` rowQ = lookupIndex c rowQ 59
+ | c `elem` rowA = lookupIndex c rowA 60
+ | c `elem` rowZ = lookupIndex c rowZ 61
+ | otherwise = Nothing
+ where
+ row1 = "1234567890-="
+ rowQ = "qwertyuiop[]"
+ rowA = "asdfghjkl;'"
+ rowZ = "zxcvbnm,./"
+ lookupIndex key row base = (\x -> base + x * 2) <$> elemIndex key row
+
+keyboardAction :: Keyboard -> Char -> EventM Name AppState ()
+keyboardAction (KeyB Nothing) _ = return ()
+keyboardAction (KeyB (Just sd)) c = do
+ env <- gets asEnvironment
+ case jankoMidi c of
+ Just n -> liftIO $ evalSoundOnce sd n env
+ Nothing -> return ()
+
+evalSoundOnce :: T.Text -> Int -> Environment -> IO ()
+evalSoundOnce func num env = do
+ _ <- runCI env (compilerInterpreterWithBlock 0 (func <> " " <> T.show num))
+ return ()
+
+selectSound :: EventM Name AppState ()
+selectSound = do
+ msound <- liftIO (inputBox "" "Select a function to trigger events" (Just "(\\x -> once $ sinus # note x)"))
+ let alt (Just (Window x y (KeyboardContent _) z l)) = Just $ Window x y (KeyboardContent (KeyB msound)) z l
+ alt _ = Nothing
+ modify $ \as -> as {asWindows = Map.alter alt Keyboard $ asWindows as}
diff --git a/app/zwirnmill/Keymap.hs b/app/zwirnmill/Keymap.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Keymap.hs
@@ -0,0 +1,124 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+{- HLINT ignore "Use tuple-section" -}
+
+module Keymap where
+
+import Brick.Keybindings
+import qualified Brick.Keybindings.KeyEvents as B
+import Conferer.Config ((/.))
+import Conferer.FromConfig (DefaultConfig (..), FromConfig (..), fetchFromConfig)
+import Data.List (groupBy)
+import qualified Data.Text as T
+import Data.Tuple (swap)
+import Data.Yaml (ToJSON (..), Value (..), object, (.=))
+import Editor.Keymap (EditorAction (..), editorKeyConfigWithUserConfig, editorKeyEvents)
+import qualified Graphics.Vty as V
+
+data GlobalAction
+ = Quit
+ | Hush
+ | Panic
+ | CustomAction T.Text
+ deriving (Show, Eq, Ord)
+
+data FullKeyConfig = FullKeyConfig
+ { kGlobal :: KeyConfig GlobalAction,
+ kEditor :: KeyConfig EditorAction
+ }
+ deriving (Show)
+
+data CustomKeymap = CustomKeymap
+ { customGlobal :: [(Binding, GlobalAction)],
+ customEditor :: [(Binding, EditorAction)]
+ }
+ deriving (Show)
+
+customKeyConfig :: CustomKeymap -> FullKeyConfig
+customKeyConfig (CustomKeymap gl ed) = FullKeyConfig (globalKeyConfigWithUserConfig gl) (editorKeyConfigWithUserConfig ed)
+
+defaultGlobalBindings :: [(GlobalAction, [Binding])]
+defaultGlobalBindings =
+ [ (Quit, [ctrl 'q']),
+ (Hush, [meta '.']),
+ (Panic, [meta ','])
+ ]
+
+globalKeyEventsFromUserConfig :: [(Binding, GlobalAction)] -> KeyEvents GlobalAction
+globalKeyEventsFromUserConfig conf = B.keyEvents $ map (\(_, ac) -> (ppAction ac, ac)) conf
+
+globalKeyConfigWithUserConfig :: [(Binding, GlobalAction)] -> KeyConfig GlobalAction
+globalKeyConfigWithUserConfig conf = newKeyConfig (globalKeyEventsFromUserConfig conf) defaultGlobalBindings conf'
+ where
+ conf' = map toBinding $ groupBy (\(_, a1) (_, a2) -> a1 == a2) conf
+ toBinding [] = error "Error in toBinding"
+ toBinding ((b, a) : bs) = (a, BindingList $ b : map fst bs)
+
+instance FromConfig (Binding, GlobalAction) where
+ fromConfig key configSource = do
+ b <- fetchFromConfig (key /. "binding") configSource :: IO T.Text
+ a <- fetchFromConfig (key /. "action") configSource :: IO T.Text
+ return (parseShortcut b, interpretAction a)
+ where
+ parseShortcut :: T.Text -> Binding
+ parseShortcut shortcut = case parseBinding (T.strip shortcut) of
+ Left err -> error $ "Could not parse keymap file: " <> err
+ Right b -> b
+
+instance FromConfig (Binding, EditorAction) where
+ fromConfig key configSource = do
+ b <- fetchFromConfig (key /. "binding") configSource :: IO T.Text
+ a <- fetchFromConfig (key /. "action") configSource :: IO T.Text
+ return (parseShortcut b, parseAction a)
+ where
+ parseAction :: T.Text -> EditorAction
+ parseAction x = case lookup x $ keyEventsList editorKeyEvents of
+ Just ac -> ac
+ Nothing -> error "Could not parse action in editor keymap file."
+ parseShortcut :: T.Text -> Binding
+ parseShortcut shortcut = case parseBinding (T.strip shortcut) of
+ Left err -> error $ "Could not parse keymap file: " <> err
+ Right b -> b
+
+instance FromConfig CustomKeymap where
+ fromConfig key configSource = do
+ gl <- fetchFromConfig (key /. "global") configSource :: IO [(Binding, GlobalAction)]
+ ed <- fetchFromConfig (key /. "editor") configSource :: IO [(Binding, EditorAction)]
+ return $ CustomKeymap gl ed
+
+interpretAction :: T.Text -> GlobalAction
+interpretAction txtVal = case T.toLower (T.strip txtVal) of
+ "quit" -> Quit
+ "hush" -> Hush
+ "panic" -> Panic
+ other -> CustomAction other
+
+ppAction :: GlobalAction -> T.Text
+ppAction Quit = "quit"
+ppAction Hush = "hush"
+ppAction Panic = "panic"
+ppAction (CustomAction other) = other
+
+instance ToJSON BindingState where
+ toJSON (BindingList (b : _)) = toJSON $ ppBinding b
+ toJSON _ = Null
+
+instance ToJSON Binding where
+ toJSON = toJSON . ppBinding
+
+instance ToJSON GlobalAction where
+ toJSON = toJSON . ppAction
+
+instance ToJSON EditorAction where
+ toJSON ac = maybe Null toJSON $ lookup ac $ map swap $ keyEventsList editorKeyEvents
+
+instance ToJSON CustomKeymap where
+ toJSON (CustomKeymap gl ed) =
+ object
+ [ "global" .= toJSON (map (\(b, a) -> object ["binding" .= b, "action" .= a]) gl),
+ "editor" .= toJSON (map (\(b, a) -> object ["binding" .= b, "action" .= a]) ed)
+ ]
+
+instance DefaultConfig CustomKeymap where
+ configDef = CustomKeymap [(ctrl 'q', Quit), (meta '.', Hush), (meta ',', Panic)] [(ctrl '@', Hint), (meta V.KEnter, Eval), (ctrl '_', CommentLine)]
diff --git a/app/zwirnmill/Main.hs b/app/zwirnmill/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Main.hs
@@ -0,0 +1,58 @@
+module Main where
+
+import qualified Brick.Animation as A
+import Brick.BChan (BChan, newBChan, writeBChan)
+import Config
+import Control.Concurrent
+import Control.Monad
+import Editor.Core (OutputType (..))
+import qualified Graphics.Vty as V
+import Keymap (CustomKeymap (..), customKeyConfig)
+import Session (SessionState (..), getSessionState)
+import Setup
+import Sound.Doux.Engine (destroy)
+import UI
+import UI.Config (windowMapFromConfig)
+import UI.Core
+import Zwirn.Doux.Types (Stream (..))
+import Zwirn.Language (Environment)
+import Zwirn.Language.Compiler (Environment (..))
+import Zwirn.Language.Environment (extend)
+import Zwirn.Language.Evaluate (Expression (..), ToExpression (..), Zwirn)
+
+main :: IO ()
+main = do
+ chan <- newBChan 30
+ (fullConfig, km) <- getConfig
+ (SessionState wc) <- getSessionState
+ (env, str) <- setup fullConfig (\st -> writeBChan chan (UpdateOutput (OutputInfo, st)))
+ amgr <- A.startAnimationManager 50 chan AnimationUpdate
+ _ <- forkIO $ forever $ do
+ writeBChan chan UpdateStatus
+ threadDelay 100000
+ wm <- windowMapFromConfig (streamConfigSamples $ fullConfigStream fullConfig) wc
+ let initialState = buildAppState km amgr wm (addOutputAction chan env) str (streamConfigMaxVoices $ fullConfigStream fullConfig) chan Nothing
+ _ <- runUI initialState
+ destroy (sDoux str)
+
+buildAppState :: CustomKeymap -> A.AnimationManager AppState AppEvent Name -> WindowMap -> Environment -> Stream -> Int -> BChan AppEvent -> Maybe V.Output -> AppState
+buildAppState km amgr wm env str mx chan out =
+ AppState
+ { asEnvironment = env,
+ asStream = str,
+ asMaxVoices = mx,
+ asWindows = wm,
+ asKeyConfig = customKeyConfig km,
+ asVtyOutput = out,
+ asChan = chan,
+ asDragging = Nothing,
+ asActiveWindow = Background,
+ asOptionWindow = Nothing,
+ asAnimationManager = amgr
+ }
+
+updateOutputExp :: BChan AppEvent -> Zwirn String -> Zwirn Expression
+updateOutputExp chan = fmap (\t -> EAction $ writeBChan chan (UpdateOutput (OutputInfo, t)))
+
+addOutputAction :: BChan AppEvent -> Environment -> Environment
+addOutputAction chan env = env {intEnv = extend ("output", toExp $ updateOutputExp chan, "Text -> Action") $ intEnv env}
diff --git a/app/zwirnmill/SampleBrowser/Draw.hs b/app/zwirnmill/SampleBrowser/Draw.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/SampleBrowser/Draw.hs
@@ -0,0 +1,19 @@
+module SampleBrowser.Draw where
+
+import Brick (ViewportType (..), Widget)
+import Brick.Widgets.Core
+import qualified Data.Text as T
+import Data.Vector (Vector)
+import qualified Data.Vector as V
+import UI.Core (Name (..), SampleBrowser (..))
+
+drawSampleBrowser :: (Int, Int) -> SampleBrowser -> Widget Name
+drawSampleBrowser (sx, _) (SampleB search cont) = vBox [txt ("search: " <> search), txt $ T.replicate sx "━", viewport SampleBrowserViewport Vertical $ drawSamples search cont]
+
+drawSamples :: T.Text -> Vector (T.Text, Int) -> Widget Name
+drawSamples search ss = vBox $ map drawSample (V.toList fs)
+ where
+ fs = V.filter (\(t, _) -> T.isPrefixOf (T.toLower search) (T.toLower t)) ss
+
+drawSample :: (T.Text, Int) -> Widget Name
+drawSample (name, num) = txt $ name <> " (" <> T.show num <> ")"
diff --git a/app/zwirnmill/SampleBrowser/Event.hs b/app/zwirnmill/SampleBrowser/Event.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/SampleBrowser/Event.hs
@@ -0,0 +1,41 @@
+module SampleBrowser.Event where
+
+import Brick (BrickEvent (..), EventM, vScrollBy, viewportScroll)
+import Brick.Types (gets)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import qualified Graphics.Vty as V
+import UI.Core (AppState (..), Name (..), SampleBrowser (..))
+import Zwirn.Language.Compiler (Environment, compilerInterpreterWithBlock, runCI)
+
+handleSampleBrowserEvent :: SampleBrowser -> BrickEvent Name e -> EventM Name AppState SampleBrowser
+handleSampleBrowserEvent s (VtyEvent (V.EvKey (V.KChar '\t') _)) = return s
+handleSampleBrowserEvent (SampleB search vs) (VtyEvent (V.EvKey (V.KChar x) _)) = return (SampleB (T.snoc search x) vs)
+handleSampleBrowserEvent (SampleB search vs) (VtyEvent (V.EvKey V.KBS _)) = case T.unsnoc search of
+ Just (rest, _) -> return (SampleB rest vs)
+ Nothing -> return (SampleB T.empty vs)
+handleSampleBrowserEvent s (MouseDown name V.BScrollUp _ _) = when (isSamp name) (vScrollBy (viewportScroll SampleBrowserViewport) (-1)) >> return s
+handleSampleBrowserEvent s (MouseDown name V.BScrollDown _ _) = when (isSamp name) (vScrollBy (viewportScroll SampleBrowserViewport) 1) >> return s
+handleSampleBrowserEvent s _ = return s
+
+isSamp :: Name -> Bool
+isSamp SampleBrowser = True
+isSamp SampleBrowserViewport = True
+isSamp _ = False
+
+sampleBrowserClickAction :: SampleBrowser -> (Int, Int) -> EventM Name AppState SampleBrowser
+sampleBrowserClickAction (SampleB search vs) (mx, my) = do
+ let fs = V.filter (\(t, _) -> T.isPrefixOf (T.toLower search) (T.toLower t)) vs
+ case fs V.!? (my - 3) of
+ Just (samp, _) -> do
+ env <- gets asEnvironment
+ liftIO $ evalSampOnce samp (mx - 1) env
+ return (SampleB search vs)
+ Nothing -> return (SampleB search vs)
+
+evalSampOnce :: T.Text -> Int -> Environment -> IO ()
+evalSampOnce samp num env = do
+ _ <- runCI env (compilerInterpreterWithBlock 0 ("once $ s " <> T.show samp <> "# n " <> T.show num))
+ return ()
diff --git a/app/zwirnmill/SampleBrowser/Load.hs b/app/zwirnmill/SampleBrowser/Load.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/SampleBrowser/Load.hs
@@ -0,0 +1,30 @@
+module SampleBrowser.Load where
+
+import Data.List (sortBy)
+import Data.Maybe (catMaybes)
+import qualified Data.Text as T
+import Data.Vector (Vector, fromList)
+import System.Directory.OsPath (doesDirectoryExist, listDirectory)
+import System.OsPath (decodeUtf, encodeUtf, takeFileName, ())
+import System.OsPath.Types (OsPath)
+import UI.Core (SampleBrowser (..))
+
+loadSampleBrowser :: FilePath -> IO SampleBrowser
+loadSampleBrowser path = loadSamples path >>= \sv -> return $ SampleB T.empty sv
+
+loadSamples :: FilePath -> IO (Vector (T.Text, Int))
+loadSamples path = do
+ ospath <- encodeUtf path
+ ps <- listDirectory ospath
+ samps <- catMaybes <$> mapM (loadSample ospath) ps
+ return $ fromList $ sortBy (\(t1, _) (t2, _) -> compare t1 t2) samps
+
+loadSample :: OsPath -> OsPath -> IO (Maybe (T.Text, Int))
+loadSample root name = do
+ ex <- doesDirectoryExist (root name)
+ if ex
+ then do
+ ss <- listDirectory (root name)
+ name' <- decodeUtf $ takeFileName name
+ return $ Just (T.pack name', length ss)
+ else return Nothing
diff --git a/app/zwirnmill/Session.hs b/app/zwirnmill/Session.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Session.hs
@@ -0,0 +1,69 @@
+module Session where
+
+import Brick (EventM)
+import Brick.Main (halt)
+import Conferer (fetch, mkConfig')
+import Conferer.FromConfig (DefaultConfig (..), FromConfig (..), fetchFromConfig, (/.))
+import qualified Conferer.Source.Yaml as Yaml
+import Control.Monad (unless)
+import Control.Monad.RWS
+import Data.Maybe (fromMaybe)
+import Data.Yaml (ToJSON (..), encodeFile, object, (.=))
+import System.Directory.OsPath (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
+import System.OsPath (OsPath, decodeFS, decodeUtf, encodeUtf, ())
+import UI.Config
+import UI.Core (AppState (..), Name)
+
+newtype SessionState = SessionState
+ { windowState :: [WindowConfig]
+ }
+
+instance ToJSON SessionState where
+ toJSON (SessionState wc) = object ["windows" .= toJSON wc]
+
+instance FromConfig SessionState where
+ fromConfig key configSource = do
+ wins <- fetchFromConfig (key /. "windows") configSource
+ return $ SessionState $ fromMaybe configDef wins
+
+instance DefaultConfig SessionState where
+ configDef = SessionState configDef
+
+getStatePath :: IO OsPath
+getStatePath = do
+ appname <- encodeUtf "zwirnmill"
+ configname <- encodeUtf "session.state"
+ configDirPath <- getXdgDirectory XdgState appname
+ let path = configDirPath configname
+ createDirectoryIfMissing True configDirPath
+ return path
+
+getSessionState :: IO SessionState
+getSessionState = do
+ path <- getStatePath
+ exists <- doesFileExist path
+ unless exists encodeDefaultSessionState
+ decoded <- decodeUtf path
+ conf <-
+ mkConfig'
+ []
+ [ Yaml.fromFilePath decoded
+ ]
+ fetch conf
+
+encodeDefaultSessionState :: IO ()
+encodeDefaultSessionState = encodeSessionState configDef
+
+encodeSessionState :: SessionState -> IO ()
+encodeSessionState ss = do
+ path <- getStatePath
+ strp <- decodeFS path
+ encodeFile strp $ toJSON ss
+
+saveWindowState :: EventM Name AppState ()
+saveWindowState = do
+ ws <- gets asWindows
+ liftIO $ encodeSessionState (SessionState (configFromWindowMap ws))
+
+quitEvent :: EventM Name AppState ()
+quitEvent = saveWindowState >> halt
diff --git a/app/zwirnmill/Setup.hs b/app/zwirnmill/Setup.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/Setup.hs
@@ -0,0 +1,42 @@
+module Setup where
+
+{-
+ Setup.hs - setup of the various components of the backend
+ Copyright (C) 2023, Martin Gius
+
+ This library is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this library. If not, see .
+-}
+
+import Config as C
+import Data.Maybe (fromMaybe)
+import Data.Ratio ((%))
+import Zwirn.Doux.Env
+import Zwirn.Doux.Types (Stream (..))
+import Zwirn.Doux.UI
+import Zwirn.Language.Compiler as Compiler
+import Zwirn.Language.Macro (defaultMacroMap)
+import Prelude hiding (log)
+
+setup :: FullConfig -> (String -> IO ()) -> IO (Environment, Stream)
+setup config log = do
+ str <- setupStream config
+ let initE = getInitialEnv (toCiConfig $ fullConfigCi config) str
+ env <- fromMaybe initE <$> checkBoot log (ciConfigBootPath $ fullConfigCi config) initE
+ return (env, str)
+
+setupStream :: FullConfig -> IO Stream
+setupStream config = startStream (toStream (1 % fromIntegral (C.ciConfigPrecision $ fullConfigCi config)) $ fullConfigStream config)
+
+getInitialEnv :: Compiler.CiConfig -> Stream -> Environment
+getInitialEnv config str = Environment (sState str) (playEnvFromStream str) (builtinEnvironmentWithStream str) (Just $ ConfigEnv configPath resetConfig) config defaultMacroMap
diff --git a/app/zwirnmill/UI.hs b/app/zwirnmill/UI.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI.hs
@@ -0,0 +1,39 @@
+module UI where
+
+import Brick hiding (on)
+import Control.Monad (when)
+import Control.Monad.RWS
+import EnvBrowser.Event (updateEnvBrowser)
+import qualified Graphics.Vty as V
+import qualified Graphics.Vty.CrossPlatform as VCP
+import System.IO (hFlush, stdout)
+import UI.Attributes
+import UI.Core
+import UI.Draw
+import UI.Event
+
+app :: App AppState AppEvent Name
+app =
+ App
+ { appDraw = drawUI,
+ appChooseCursor = showFirstCursor,
+ appHandleEvent = handleEvent,
+ appStartEvent = setLineCursor >> updateEnvBrowser,
+ appAttrMap = const attributeMap
+ }
+
+runUI :: AppState -> IO AppState
+runUI initialState = do
+ let buildVty = VCP.mkVty V.defaultConfig {V.configInputMap = [(Nothing, "\ESC[13;5u", V.EvKey V.KEnter [V.MCtrl])]}
+ vty <- buildVty
+ let output = V.outputIface vty
+ when (V.supportsMode output V.Mouse) $
+ V.setMode output V.Mouse True
+ when (V.supportsMode output V.BracketedPaste) $
+ V.setMode output V.BracketedPaste True
+ customMain vty buildVty (Just $ asChan initialState) app initialState {asVtyOutput = Just output}
+
+setLineCursor :: EventM n s ()
+setLineCursor = liftIO $ do
+ putStr "\ESC[5 q"
+ hFlush stdout
diff --git a/app/zwirnmill/UI/Attributes.hs b/app/zwirnmill/UI/Attributes.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI/Attributes.hs
@@ -0,0 +1,94 @@
+module UI.Attributes where
+
+import Brick hiding (on)
+import qualified Graphics.Vty as V
+
+attrStatusBar :: AttrName
+attrStatusBar = attrName "statusbar"
+
+attrLink :: AttrName
+attrLink = attrName "link"
+
+attrCurrentLink :: AttrName
+attrCurrentLink = attrName "currentlink"
+
+attrDocStrong :: AttrName
+attrDocStrong = attrName "strog"
+
+attrDocEmph :: AttrName
+attrDocEmph = attrName "emph"
+
+attrDocCode :: AttrName
+attrDocCode = attrName "code"
+
+attrCursor :: AttrName
+attrCursor = attrName "cursor"
+
+attrSelected :: AttrName
+attrSelected = attrName "selected"
+
+attrCurrentLine :: AttrName
+attrCurrentLine = attrName "currentline"
+
+attrFlash :: AttrName
+attrFlash = attrName "flash"
+
+attrFlashError :: AttrName
+attrFlashError = attrName "flasherror"
+
+attrCurrentLineNum :: AttrName
+attrCurrentLineNum = attrName "currentlinenum"
+
+attrLineNum :: AttrName
+attrLineNum = attrName "linenum"
+
+attrError :: AttrName
+attrError = attrName "error"
+
+syntax :: AttrName
+syntax = attrName "syntax"
+
+syntaxText :: AttrName
+syntaxText = syntax <> attrName "text"
+
+syntaxNumber :: AttrName
+syntaxNumber = syntax <> attrName "number"
+
+syntaxOperator :: AttrName
+syntaxOperator = syntax <> attrName "operator"
+
+syntaxSilence :: AttrName
+syntaxSilence = syntax <> attrName "silence"
+
+syntaxKeyword :: AttrName
+syntaxKeyword = syntax <> attrName "keyword"
+
+attributeMap :: AttrMap
+attributeMap =
+ attrMap
+ V.defAttr
+ [ (attrLineNum, V.defAttr),
+ (attrCurrentLineNum, V.withBackColor V.defAttr V.brightBlack),
+ (attrStatusBar, bg V.brightBlack),
+ (attrSelected, bg V.black),
+ (attrCurrentLine, bg V.brightBlack),
+ (attrLink, fg V.brightBlue),
+ (attrCurrentLink, V.withStyle (fg V.brightBlue) V.underline),
+ (attrDocEmph, V.withStyle (fg V.brightCyan) V.italic),
+ (attrDocStrong, V.withStyle (fg V.brightMagenta) V.bold),
+ (attrDocCode, fg V.brightCyan),
+ (attrFlash, bg V.brightGreen),
+ (attrFlashError, bg V.brightRed),
+ (attrError, V.withStyle (fg V.red) V.underline),
+ (attrSelected <> attrError, V.withBackColor (V.withStyle (fg V.red) V.underline) V.black),
+ (syntaxText, fg V.brightBlue),
+ (syntaxNumber, fg V.brightCyan),
+ (syntaxOperator, fg V.brightMagenta),
+ (syntaxSilence, fg V.brightCyan),
+ (syntaxKeyword, fg V.magenta),
+ (attrSelected <> syntaxText, V.withBackColor (fg V.brightBlue) V.black),
+ (attrSelected <> syntaxNumber, V.withBackColor (fg V.brightCyan) V.black),
+ (attrSelected <> syntaxOperator, V.withBackColor (fg V.brightMagenta) V.black),
+ (attrSelected <> syntaxSilence, V.withBackColor (fg V.brightCyan) V.black),
+ (attrSelected <> syntaxKeyword, V.withBackColor (fg V.magenta) V.black)
+ ]
diff --git a/app/zwirnmill/UI/Config.hs b/app/zwirnmill/UI/Config.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI/Config.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module UI.Config where
+
+import Conferer (DefaultConfig (..))
+import Conferer.FromConfig (FromConfig (..), fetchFromConfig, (/.))
+import Data.List (mapAccumL)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, isJust)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import Data.Yaml (ToJSON (..), object, (.=))
+import Docs.Markdown (docMap, startDoc)
+import Editor.Config (EditorConfig (..), editorFromConfig)
+import Editor.Core (esFilePath, esTabWidth)
+import Editor.Util (getContent)
+import Lens.Micro ((^.))
+import SampleBrowser.Load (loadSampleBrowser)
+import UI.Core (AnimationConfig (..), Content (..), DocFocus (..), DocumentationConfig (..), EnvBrowser (..), Keyboard (..), Name (..), SampleBrowser (..), Window (..), WindowMap)
+
+data WindowConfig = WindowConfig
+ { windowConfigPosX :: Int,
+ windowConfigPosY :: Int,
+ windowConfigSizeX :: Int,
+ windowConfigSizeY :: Int,
+ windowConfigHidden :: Bool,
+ windowConfigBorder :: Bool,
+ windowConfigContent :: WindowContentConfig
+ }
+ deriving (Show)
+
+data WindowContentConfig
+ = WindowAnimationConfig AnimationConfig
+ | WindowEditorConfig EditorConfig
+ | WindowOutputConfig
+ | WindowStatusConfig
+ | WindowSliderConfig
+ | WindowSampleBrowserConfig
+ | WindowEnvBrowserConfig
+ | WindowKeyboardConfig
+ | WindowDocumentationConfig DocumentationConfig
+ deriving (Show)
+
+instance DefaultConfig [WindowConfig] where
+ configDef =
+ [ WindowConfig 0 0 51 28 False False (WindowEditorConfig $ EditorConfig 4 Nothing Nothing),
+ WindowConfig 51 0 23 11 False False WindowStatusConfig,
+ WindowConfig 51 11 23 17 False True WindowOutputConfig,
+ WindowConfig 74 00 29 28 False False (WindowDocumentationConfig (DocumentationConfig Nothing)),
+ WindowConfig 0 28 51 7 True True (WindowAnimationConfig $ AnimationConfig 150 "")
+ ]
+
+instance FromConfig WindowConfig where
+ fromConfig key configSource = do
+ pX <- fetchFromConfig (key /. "posx") configSource
+ pY <- fetchFromConfig (key /. "posy") configSource
+ sX <- fetchFromConfig (key /. "sizex") configSource
+ sY <- fetchFromConfig (key /. "sizey") configSource
+ b <- fetchFromConfig (key /. "border") configSource
+ h <- fetchFromConfig (key /. "hidden") configSource
+ wContent <- fetchFromConfig (key /. "content") configSource
+ return $
+ WindowConfig
+ { windowConfigPosX = fromMaybe 0 pX,
+ windowConfigPosY = fromMaybe 0 pY,
+ windowConfigSizeX = fromMaybe 0 sX,
+ windowConfigSizeY = fromMaybe 0 sY,
+ windowConfigHidden = fromMaybe False h,
+ windowConfigBorder = fromMaybe True b,
+ windowConfigContent = wContent
+ }
+
+instance FromConfig WindowContentConfig where
+ fromConfig key configSource = do
+ typ <- fetchFromConfig (key /. "type") configSource :: IO (Maybe String)
+ case typ of
+ Just "status" -> pure WindowStatusConfig
+ Just "output" -> pure WindowOutputConfig
+ Just "slider" -> pure WindowSliderConfig
+ Just "samplebrowser" -> pure WindowSampleBrowserConfig
+ Just "keyboard" -> pure WindowKeyboardConfig
+ Just "envbrowser" -> pure WindowEnvBrowserConfig
+ Just "animation" -> WindowAnimationConfig <$> fetchFromConfig key configSource
+ Just "editor" -> WindowEditorConfig <$> fetchFromConfig key configSource
+ Just "documentation" -> WindowDocumentationConfig <$> fetchFromConfig key configSource
+ _ -> pure WindowStatusConfig
+
+instance FromConfig AnimationConfig where
+ fromConfig key configSource = do
+ r <- fetchFromConfig (key /. "rate") configSource
+ p <- fetchFromConfig (key /. "path") configSource
+ return (AnimationConfig (fromMaybe 150 r) (fromMaybe "" p))
+
+instance FromConfig DocumentationConfig where
+ fromConfig key configSource = do
+ p <- fetchFromConfig (key /. "page") configSource
+ return (DocumentationConfig p)
+
+windowFromConfig :: Maybe FilePath -> WindowConfig -> IO Window
+windowFromConfig mf (WindowConfig x y sx sy hidden border conf) = do
+ cont <- contentFromType mf conf
+ return $ Window (x, y) (sx, sy) cont hidden border
+
+contentFromType :: Maybe FilePath -> WindowContentConfig -> IO Content
+contentFromType _ (WindowEditorConfig c) = do
+ es <- editorFromConfig c
+ return $ EditorContent es
+contentFromType _ WindowStatusConfig = return $ StatusContent "" 138 0.575 0 0 (0, 32) 0 0 0
+contentFromType _ WindowOutputConfig = return $ OutputContent []
+contentFromType _ WindowSliderConfig = return $ SliderContent 0.5
+contentFromType (Just p) WindowSampleBrowserConfig = loadSampleBrowser p >>= \sb -> return $ SampleBrowserContent sb
+contentFromType _ WindowSampleBrowserConfig = return $ SampleBrowserContent (SampleB T.empty V.empty)
+contentFromType _ WindowEnvBrowserConfig = return $ EnvBrowserContent (EnvB T.empty V.empty)
+contentFromType _ WindowKeyboardConfig = return $ KeyboardContent (KeyB Nothing)
+contentFromType _ (WindowDocumentationConfig (DocumentationConfig Nothing)) = return $ DocumentationContent startDoc NoFocus docMap
+contentFromType _ (WindowDocumentationConfig (DocumentationConfig (Just k))) = case Map.lookup k docMap of
+ Just d -> return $ DocumentationContent d NoFocus docMap
+ Nothing -> return $ DocumentationContent startDoc NoFocus docMap
+contentFromType _ (WindowAnimationConfig c) = return $ AnimationContent Nothing c
+
+windowMapFromConfig :: Maybe FilePath -> [WindowConfig] -> IO WindowMap
+windowMapFromConfig mf wcs = addHidden . Map.fromList <$> liftA2 zip ns ws
+ where
+ ws = mapM (windowFromConfig mf) wcs
+ ns = snd . mapAccumL (\st win -> windowNameFromContent st $ windowContent win) (0, 0) <$> ws
+
+windowNameFromContent :: (Int, Int) -> Content -> ((Int, Int), Name)
+windowNameFromContent (editors, sliders) (EditorContent _) = ((editors + 1, sliders), Editor $ editors + 1)
+windowNameFromContent (editors, sliders) (SliderContent _) = ((editors, sliders + 1), Slider $ sliders + 1)
+windowNameFromContent st (StatusContent {}) = (st, Status)
+windowNameFromContent st (OutputContent {}) = (st, Output)
+windowNameFromContent st (AnimationContent {}) = (st, Animator)
+windowNameFromContent st (DocumentationContent {}) = (st, Documentation)
+windowNameFromContent st (SampleBrowserContent {}) = (st, SampleBrowser)
+windowNameFromContent st (EnvBrowserContent {}) = (st, EnvBrowser)
+windowNameFromContent st (KeyboardContent {}) = (st, Keyboard)
+
+addHidden :: WindowMap -> WindowMap
+addHidden wm = insertKeyboard $ insertEnv $ insertSamples $ insertDoc $ insertStatus $ insertOutput $ insertAnimator wm
+ where
+ defaultWindow c = Window (0, 0) (10, 10) c True False
+ insertStatus = if Map.notMember Status wm then Map.insert Status (defaultWindow (StatusContent "" 138 0.575 0 0 (0, 32) 0 0 0)) else id
+ insertOutput = if Map.notMember Output wm then Map.insert Output (defaultWindow (OutputContent [])) else id
+ insertAnimator = if Map.notMember Animator wm then Map.insert Animator (defaultWindow (AnimationContent Nothing (AnimationConfig 150 ""))) else id
+ insertDoc = if Map.notMember Documentation wm then Map.insert Documentation (defaultWindow (DocumentationContent startDoc NoFocus docMap)) else id
+ insertSamples = if Map.notMember SampleBrowser wm then Map.insert SampleBrowser (defaultWindow (SampleBrowserContent (SampleB T.empty V.empty))) else id
+ insertEnv = if Map.notMember EnvBrowser wm then Map.insert EnvBrowser (defaultWindow (EnvBrowserContent (EnvB T.empty V.empty))) else id
+ insertKeyboard = if Map.notMember Keyboard wm then Map.insert Keyboard (defaultWindow (KeyboardContent (KeyB Nothing))) else id
+
+configFromContent :: Content -> WindowContentConfig
+configFromContent (EditorContent es) = WindowEditorConfig $ EditorConfig (es ^. esTabWidth) (es ^. esFilePath) (if isJust (es ^. esFilePath) then Nothing else Just $ getContent es)
+configFromContent (StatusContent {}) = WindowStatusConfig
+configFromContent (OutputContent _) = WindowOutputConfig
+configFromContent (SliderContent _) = WindowSliderConfig
+configFromContent (SampleBrowserContent _) = WindowSampleBrowserConfig
+configFromContent (EnvBrowserContent _) = WindowEnvBrowserConfig
+configFromContent (KeyboardContent _) = WindowKeyboardConfig
+configFromContent (AnimationContent _ c) = WindowAnimationConfig c
+configFromContent (DocumentationContent d _ m) = case Map.keys (Map.filter (== d) m) of
+ (x : _) -> WindowDocumentationConfig (DocumentationConfig (Just x))
+ _ -> WindowDocumentationConfig (DocumentationConfig Nothing)
+
+configFromWindow :: Window -> WindowConfig
+configFromWindow (Window (px, py) (sx, sy) c h b) = WindowConfig px py sx sy h b (configFromContent c)
+
+configFromWindowMap :: WindowMap -> [WindowConfig]
+configFromWindowMap = map configFromWindow . Map.elems
+
+instance ToJSON WindowContentConfig where
+ toJSON WindowOutputConfig = object ["type" .= ("output" :: String)]
+ toJSON WindowStatusConfig = object ["type" .= ("status" :: String)]
+ toJSON WindowSliderConfig = object ["type" .= ("slider" :: String)]
+ toJSON WindowSampleBrowserConfig = object ["type" .= ("samplebrowser" :: String)]
+ toJSON WindowEnvBrowserConfig = object ["type" .= ("envbrowser" :: String)]
+ toJSON WindowKeyboardConfig = object ["type" .= ("keyboard" :: String)]
+ toJSON (WindowDocumentationConfig (DocumentationConfig k)) =
+ object
+ [ "type" .= ("documentation" :: String),
+ "page" .= k
+ ]
+ toJSON (WindowAnimationConfig (AnimationConfig i p)) =
+ object
+ [ "type" .= ("animation" :: String),
+ "rate" .= i,
+ "path" .= p
+ ]
+ toJSON (WindowEditorConfig (EditorConfig i p c)) =
+ object
+ [ "type" .= ("editor" :: String),
+ "tabwidth" .= i,
+ "path" .= p,
+ "content" .= c
+ ]
+
+instance ToJSON WindowConfig where
+ toJSON (WindowConfig px py sx sy h b c) =
+ object
+ [ "posx" .= px,
+ "posy" .= py,
+ "sizex" .= sx,
+ "sizey" .= sy,
+ "hidden" .= h,
+ "border" .= b,
+ "content" .= toJSON c
+ ]
diff --git a/app/zwirnmill/UI/Core.hs b/app/zwirnmill/UI/Core.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI/Core.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module UI.Core where
+
+import Brick (EventM)
+import qualified Brick.Animation as A
+import Brick.BChan (BChan)
+import Control.Monad.RWS
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Data.Vector (Vector)
+import Editor.Core
+import qualified Graphics.Vty as V
+import Keymap (FullKeyConfig)
+import Lens.Micro.TH (makeLenses)
+import Zwirn.Doux.Types (Stream)
+import Zwirn.Language.Compiler (Environment, runCIEnv, setExpression)
+import Zwirn.Language.Evaluate.Expression
+import Zwirn.Language.TypeCheck.Types (Qualified (..), Scheme (..), numberT)
+
+data Name
+ = Editor Int
+ | EditorViewport Int
+ | Cursor
+ | Status
+ | Output
+ | Slider Int
+ | Background
+ | OptionWin
+ | Animator
+ | SampleBrowser
+ | SampleBrowserViewport
+ | Keyboard
+ | EnvBrowser
+ | EnvBrowserViewport
+ | Documentation
+ | DocViewport
+ | DocLink Int
+ | DocCode Int
+ deriving (Eq, Ord, Show)
+
+data AppEvent
+ = FileSelected (Maybe FilePath)
+ | UpdateStatus
+ | UpdateOutput (OutputType, String)
+ | UpdateEnv
+ | ClearFlash
+ | AnimationUpdate (EventM Name AppState ())
+
+data DragAction
+ = Move
+ | ResizeBottom
+ | ResizeRight
+ | ResizeBoth
+ | Content
+ deriving (Eq, Show)
+
+data AnimationConfig = AnimationConfig {animationConfigRate :: Int, animationConfigPath :: String}
+ deriving (Show, Eq)
+
+data Content
+ = StatusContent String Double Double Int Double (Int, Int) Int Int Double
+ | OutputContent [(OutputType, String)]
+ | EditorContent EditorState
+ | SliderContent Double
+ | AnimationContent (Maybe (A.Animation AppState Name)) AnimationConfig
+ | DocumentationContent Doc DocFocus DocMap
+ | SampleBrowserContent SampleBrowser
+ | EnvBrowserContent EnvBrowser
+ | KeyboardContent Keyboard
+
+newtype DocumentationConfig = DocumentationConfig (Maybe T.Text)
+ deriving (Show, Eq)
+
+newtype Keyboard = KeyB {kSound :: Maybe T.Text}
+
+data SampleBrowser = SampleB
+ { sbSearchString :: T.Text,
+ sbContent :: Vector (T.Text, Int)
+ }
+
+data EnvBrowser = EnvB
+ { ebSearchString :: T.Text,
+ ebContent :: Vector T.Text
+ }
+
+data DocFocus
+ = CodeFocus Int
+ | LinkFocus Int
+ | NoFocus
+ deriving (Eq, Show)
+
+data DocStyle
+ = Normal
+ | Emph
+ | Strong
+ | Code
+ deriving (Eq, Show)
+
+data DocInline
+ = TextChunk T.Text DocStyle
+ | Link T.Text T.Text
+ | Linebreak
+ deriving (Show, Eq)
+
+data DocBlock
+ = Paragraph [DocInline]
+ | CodeBlock T.Text
+ deriving (Show, Eq)
+
+newtype Doc = Doc [DocBlock]
+ deriving (Show, Eq)
+
+type DocMap = Map.Map T.Text Doc
+
+data Option
+ = Hide
+ | Close
+ | Show Name
+ | AddEditor
+ | AddSlider
+ | ToggleAnimation
+ | ChangeAnimation
+ | ChangeFramerate
+ | SetBootPath
+ | SetSamplePath
+ | ToggleLabel
+ | QuitMill
+ | Copy
+ | GotoStart
+ | OpenConfig
+ | OpenKeymap
+ | SelectAction
+ deriving (Eq, Show)
+
+data OptionWindow = OptionWindow
+ { optionPos :: (Int, Int),
+ optionParent :: Name,
+ options :: [Option]
+ }
+
+data Window = Window
+ { windowPos :: (Int, Int),
+ windowSize :: (Int, Int),
+ windowContent :: Content,
+ windowHidden :: Bool,
+ windowLabel :: Bool
+ }
+
+type WindowMap = Map.Map Name Window
+
+data AppState = AppState
+ { asWindows :: WindowMap,
+ asEnvironment :: Environment,
+ asStream :: Stream,
+ asMaxVoices :: Int,
+ asKeyConfig :: FullKeyConfig,
+ asVtyOutput :: Maybe V.Output,
+ asChan :: BChan AppEvent,
+ asDragging :: Maybe ((Int, Int), Name, DragAction),
+ asActiveWindow :: Name,
+ asOptionWindow :: Maybe OptionWindow,
+ asAnimationManager :: A.AnimationManager AppState AppEvent Name
+ }
+
+updateSlider :: Int -> Double -> Environment -> IO Environment
+updateSlider slidern val env = do
+ x <- runCIEnv env (setExpression ("slider" <> T.show slidern) (Forall [] $ Qual [] [] numberT) (EZwirn $ pure $ ENum val))
+ case x of
+ Right (_, env') -> return env'
+ Left _ -> return env
+
+newSlider :: Int -> EventM Name AppState Window
+newSlider i = do
+ env <- gets asEnvironment
+ env' <- liftIO $ updateSlider i 0.5 env
+ modify (\as -> as {asEnvironment = env'})
+ return $ Window (0, 0) (30, 3) (SliderContent 0.5) False False
+
+data EditorEventEnv = EditorEventEnv
+ { _envBChan :: BChan AppEvent,
+ _envName :: Name,
+ _envKeyConfig :: FullKeyConfig,
+ _envVtyOut :: Maybe V.Output,
+ _envEnv :: Environment,
+ _envEditorState :: EditorState
+ }
+
+makeLenses ''EditorEventEnv
diff --git a/app/zwirnmill/UI/Draw.hs b/app/zwirnmill/UI/Draw.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI/Draw.hs
@@ -0,0 +1,130 @@
+{- HLINT ignore "Use tuple-section" -}
+module UI.Draw where
+
+import Animation (drawAnimationWindow)
+import Brick hiding (on)
+import Brick.Widgets.Border
+import Brick.Widgets.Border.Style (BorderStyle (..), unicodeRounded)
+import qualified Data.Map as Map
+import Data.Version (showVersion)
+import Docs.Draw (drawDoc)
+import Editor.Core (OutputType (..), esPopup)
+import Editor.Draw
+import EnvBrowser.Draw (drawEnvBrowser)
+import Keyboard.Draw (drawKeyboard)
+import Lens.Micro
+import Paths_zwirn (version)
+import SampleBrowser.Draw (drawSampleBrowser)
+import UI.Attributes (attrError)
+import UI.Core
+
+drawUI :: AppState -> [Widget Name]
+drawUI as = opt ++ concatMap (drawWindow as active) (activeToFront (asWindows as)) ++ [background]
+ where
+ active = asActiveWindow as
+ opt = maybe [] drawOptionWindow $ asOptionWindow as
+ activeToFront wm = case Map.lookup active wm of
+ Just win -> (active, win) : Map.toList (Map.delete active wm)
+ Nothing -> Map.toList wm
+
+drawWindow :: AppState -> Name -> (Name, Window) -> [Widget Name]
+drawWindow _ _ (_, Window _ _ _ True _) = []
+drawWindow _ active (name, Window pos size (StatusContent ver bpm cps cyc load voices peak schedule samples) _ l) = withWindow (active == name) l name pos size (drawStatus size (ver, bpm, cps, cyc, load, voices, peak, schedule, samples)) Nothing
+drawWindow _ active (name, Window pos size (EditorContent es) _ l) = withWindow (active == name) l name pos size (drawEditor (active == name) (name, size, es)) (Just $ drawPopup $ es ^. esPopup)
+drawWindow _ active (name, Window pos size (OutputContent os) _ l) = withWindow (active == name) l name pos size (drawOutput size os) Nothing
+drawWindow _ active (name, Window pos size (SliderContent s) _ l) = withWindow (active == name) l name pos size (drawSlider size s) Nothing
+drawWindow as active (name, Window pos size (AnimationContent a _) _ l) = withWindow (active == name) l name pos size (drawAnimationWindow as size a) Nothing
+drawWindow _ active (name, Window pos size (DocumentationContent d c _) _ l) = withWindow (active == name) l name pos size (drawDoc size d c) Nothing
+drawWindow _ active (name, Window pos size (SampleBrowserContent s) _ l) = withWindow (active == name) l name pos size (drawSampleBrowser size s) Nothing
+drawWindow _ active (name, Window pos size (EnvBrowserContent s) _ l) = withWindow (active == name) l name pos size (drawEnvBrowser size s) Nothing
+drawWindow _ active (name, Window pos size (KeyboardContent s) _ l) = withWindow (active == name) l name pos size (drawKeyboard size s) Nothing
+
+withWindow :: Bool -> Bool -> Name -> (Int, Int) -> (Int, Int) -> Widget Name -> Maybe (Widget Name) -> [Widget Name]
+withWindow active labeled name pos size win mpop =
+ pop
+ ++ [ translateBy
+ (Location pos)
+ $ clickable name
+ $ withBorderStyle borderStyle
+ $ hLimit (fst size)
+ $ vLimit (snd size)
+ $ labeledBorder
+ win
+ ]
+ where
+ labeledBorder = if labeled then borderWithLabel (str $ show name) else border
+ borderStyle = if active then unicodeDouble else unicodeRounded
+ pop = case mpop of
+ Just p ->
+ [ translateBy
+ (Location pos)
+ $ clickable name
+ $ hLimit (fst size - 1)
+ $ vLimit (snd size - 1) p
+ ]
+ Nothing -> []
+
+drawStatus :: (Int, Int) -> (String, Double, Double, Int, Double, (Int, Int), Int, Int, Double) -> Widget Name
+drawStatus (_, sy) (ver, bpm, cps, cyc, load, (voices, mx), peak, schedule, samples) =
+ vBox $
+ [ hBox [str $ "zwirn " <> showVersion version, fill ' '],
+ hBox [str $ "doux " <> ver, fill ' '],
+ hBox [str $ "tempo: " <> show ((fromIntegral (floor (bpm * 10 ^ (2 :: Int)) :: Int) :: Double) / 10 ^ (2 :: Int)) <> " bpm", fill ' '],
+ hBox [str $ " " <> show ((fromIntegral (floor (cps * 10 ^ (4 :: Int)) :: Int) :: Double) / 10 ^ (4 :: Int)) <> " cps", fill ' '],
+ hBox [str $ "cycle: " <> show cyc, fill ' '],
+ hBox [str $ "load: " <> show ((fromIntegral (floor (load * 10 ^ (2 :: Int)) :: Int) :: Double) / 10 ^ (2 :: Int)) <> "%", fill ' '],
+ hBox [str $ "voices: " <> show voices <> "/" <> show mx, fill ' '],
+ hBox [str $ "peak: " <> show peak, fill ' '],
+ hBox [str $ "schedule: " <> show schedule, fill ' '],
+ hBox [str $ "samples: " <> show ((fromIntegral (floor (samples * 10 ^ (2 :: Int)) :: Int) :: Double) / 10 ^ (2 :: Int)) <> "MB", fill ' ']
+ ]
+ ++ rest
+ where
+ rest = replicate (max 0 (sy - 8)) $ fill ' '
+
+drawOutput :: (Int, Int) -> [(OutputType, String)] -> Widget Name
+drawOutput (sx, sy) os = vBox $ map styled split ++ rest
+ where
+ rest = replicate (max 0 (sy - length split)) $ fill ' '
+ splitLine (t, s) = if length s > sx - 2 then let (x, y) = splitAt (sx - 2) s in (t, x) : splitLine (t, y) else [(t, s)]
+ split = concatMap splitLine $ concatMap (\(x, y) -> map (\b -> (x, b)) $ lines $ replaceTabs y) os
+ styled (OutputError, o) = hBox [withAttr attrError $ str o, fill ' ']
+ styled (OutputInfo, o) = hBox [str o, fill ' ']
+ replaceTabs = concatMap (\c -> if c == '\t' then " " else [c])
+
+background :: Widget Name
+background = clickable Background $ fill ' '
+
+unicodeDouble :: BorderStyle
+unicodeDouble =
+ BorderStyle
+ { bsCornerTL = '╔',
+ bsCornerTR = '╗',
+ bsCornerBR = '╝',
+ bsCornerBL = '╚',
+ bsIntersectFull = '╬',
+ bsIntersectL = '╠',
+ bsIntersectR = '╣',
+ bsIntersectT = '╦',
+ bsIntersectB = '╩',
+ bsHorizontal = '═',
+ bsVertical = '║'
+ }
+
+drawSlider :: (Int, Int) -> Double -> Widget Name
+drawSlider (w, _) s = str (replicate filled '▓' <> "▒" <> replicate not_filled '░') <=> fill ' '
+ where
+ width = w - 3
+ filled = (floor $ fromIntegral width * s) :: Int
+ not_filled = width - filled
+
+drawOptionWindow :: OptionWindow -> [Widget Name]
+drawOptionWindow (OptionWindow _ _ []) = []
+drawOptionWindow (OptionWindow pos _ os) =
+ return
+ $ translateBy
+ (Location pos)
+ $ border
+ $ clickable OptionWin
+ $ vBox
+ $ map (str . show) os
diff --git a/app/zwirnmill/UI/Event.hs b/app/zwirnmill/UI/Event.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI/Event.hs
@@ -0,0 +1,151 @@
+{- HLINT ignore "Use tuple-section" -}
+module UI.Event where
+
+import Brick hiding (on, str)
+import Brick.Keybindings
+import Control.Monad (unless, void)
+import Control.Monad.RWS
+import Data.List (intercalate, uncons)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Data.Time
+import Docs.Event (handleDocEvent)
+import Editor.Core (OutputType (..))
+import Editor.Event (editorToAppEvent)
+import EnvBrowser.Event (handleEnvBrowserEvent, updateEnvBrowser)
+import qualified Graphics.Vty as V
+import Keyboard.Event (handleKeyboardEvent)
+import Keymap
+import SampleBrowser.Event (handleSampleBrowserEvent)
+import Session (quitEvent)
+import Sound.Doux.Engine (activeVoices, douxVersion, load, memory, peakVoices, scheduleDepth)
+import UI.Core
+import UI.Window
+import Zwirn.Doux.Types (Stream (..))
+import Zwirn.Doux.UI (streamGetBPM, streamGetCPS, streamGetCycle)
+import Zwirn.Language.Compiler (compilerInterpreterBasic, runCIEnv)
+
+handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
+handleEvent ev = do
+ handledd <- handleGlobalEvent ev
+ unless handledd $ do
+ active <- gets getActiveWindow
+ case active of
+ Just (name, win) -> do
+ win' <- handleWindowEvent (name, win) ev
+ wm <- gets asWindows
+ modify $ \as -> as {asWindows = Map.insert name win' wm}
+ Nothing -> return ()
+
+getActiveWindow :: AppState -> Maybe (Name, Window)
+getActiveWindow as = (\val -> (asActiveWindow as, val)) <$> Map.lookup (asActiveWindow as) (asWindows as)
+
+handleWindowEvent :: (Name, Window) -> BrickEvent Name AppEvent -> EventM Name AppState Window
+handleWindowEvent (name, Window p s (EditorContent es) h l) ev = editorToAppEvent name es ev >>= \es' -> return $ Window p s (EditorContent es') h l
+handleWindowEvent (_, Window p s (DocumentationContent d c m) h l) ev = handleDocEvent d c m ev >>= \(d', f) -> return (Window p s (DocumentationContent d' f m) h l)
+handleWindowEvent (_, Window p s (SampleBrowserContent sb) h l) ev = handleSampleBrowserEvent sb ev >>= \sb' -> return (Window p s (SampleBrowserContent sb') h l)
+handleWindowEvent (_, Window p s (EnvBrowserContent sb) h l) ev = handleEnvBrowserEvent sb ev >>= \sb' -> return (Window p s (EnvBrowserContent sb') h l)
+handleWindowEvent (_, Window p s (KeyboardContent k) h l) ev = handleKeyboardEvent k ev >>= \k' -> return (Window p s (KeyboardContent k') h l)
+handleWindowEvent (_, win) _ = return win
+
+handleGlobalEvent :: BrickEvent Name AppEvent -> EventM Name AppState Bool
+handleGlobalEvent (VtyEvent (V.EvKey key mods)) = gets asKeyConfig >>= \conf -> handleKey (globalKeyDispatcher $ kGlobal conf) key mods
+handleGlobalEvent (AppEvent UpdateStatus) = handled updateStatus
+handleGlobalEvent (AppEvent UpdateEnv) = handled updateEnvBrowser
+handleGlobalEvent (AppEvent (AnimationUpdate a)) = handled a
+handleGlobalEvent (AppEvent (UpdateOutput o)) = handled $ updateOutput o
+handleGlobalEvent (MouseUp _ (Just V.BLeft) _) = handled $ modify $ \as -> as {asDragging = Nothing}
+handleGlobalEvent (MouseDown name V.BRight _ (Location pos)) = handled $ rightClickWindow name pos
+handleGlobalEvent (MouseDown OptionWin V.BLeft _ (Location pos)) = handled $ clickOptionWindow pos
+handleGlobalEvent (MouseDown name V.BLeft _ (Location (mx, my))) = handled $ do
+ closeOptions
+ drag <- gets asDragging
+ case drag of
+ Just (pos, dragged, action) -> do
+ ab <- getAbsolutePos (name, dragged) (mx, my)
+ dragWindow dragged ab pos action
+ Nothing -> clickWindow name (mx, my) >> modify (\as -> as {asActiveWindow = parentWindow name})
+handleGlobalEvent _ = return False
+
+handled :: (Monad m) => m a -> m Bool
+handled x = x >> return True
+
+hushEvent :: EventM Name AppState ()
+hushEvent = do
+ env <- gets asEnvironment
+ void $ liftIO $ runCIEnv env (compilerInterpreterBasic "hush")
+ updateOutput (OutputInfo, "Hush.")
+
+panicEvent :: EventM Name AppState ()
+panicEvent = do
+ env <- gets asEnvironment
+ void $ liftIO $ runCIEnv env (compilerInterpreterBasic "panic")
+ updateOutput (OutputInfo, "Panic.")
+
+customActionEvent :: T.Text -> EventM Name AppState ()
+customActionEvent exe = do
+ env <- gets asEnvironment
+ x <- liftIO $ runCIEnv env (compilerInterpreterBasic exe)
+ case x of
+ Right _ -> updateOutput (OutputInfo, "Ran custom action: " <> T.unpack exe)
+ Left _ -> updateOutput (OutputError, "Failed to run custom action.")
+
+updateStatus :: EventM Name AppState ()
+updateStatus = do
+ wm <- gets asWindows
+ case Map.lookup Status wm of
+ Nothing -> return ()
+ Just (Window _ _ _ True _) -> return ()
+ Just (Window _ _ _ False _) -> do
+ str <- gets asStream
+ mx <- gets asMaxVoices
+ ver <- liftIO douxVersion
+ ld <- liftIO $ realToFrac <$> load (sDoux str)
+ voices <- liftIO $ activeVoices (sDoux str)
+ peak <- liftIO $ peakVoices (sDoux str)
+ schedule <- liftIO $ scheduleDepth (sDoux str)
+ samples <- liftIO $ realToFrac <$> memory (sDoux str)
+ bpm <- liftIO $ streamGetBPM str
+ cps <- liftIO $ streamGetCPS str
+ cyc <- liftIO $ streamGetCycle str
+ let f (Just (Window p s _ False l)) = Just $ Window p s (StatusContent ver bpm cps cyc ld (voices, mx) peak schedule samples) False l
+ f _ = Nothing
+ wm' = Map.alter f Status wm
+ modify $ \as -> as {asWindows = wm'}
+
+updateOutput :: (OutputType, String) -> EventM Name AppState ()
+updateOutput (t, cont) = do
+ wm <- gets asWindows
+ case Map.lookup Output wm of
+ Just (Window _ _ (OutputContent os) False _) -> do
+ time <- liftIO getZonedTime
+ let f Nothing = Nothing
+ f (Just (Window p s _ h l)) = Just $ Window p s (OutputContent $ (t, prettyShowContent time cont) : take 20 os) h l
+ wm' = Map.alter f Output wm
+ modify $ \as -> as {asWindows = wm'}
+ _ -> return ()
+
+showTime :: ZonedTime -> String
+showTime = take 8 . show . localTimeOfDay . zonedTimeToLocalTime
+
+prettyShowContent :: ZonedTime -> String -> String
+prettyShowContent time cont = case uncons $ lines cont of
+ Just (x, xs) -> showTime time <> " - " <> intercalate "\n" (x : map (\y -> replicate 11 ' ' <> y) xs)
+ Nothing -> showTime time <> " - " <> cont
+
+globalEventHandlerConstructor :: GlobalAction -> (T.Text, EventM Name AppState ())
+globalEventHandlerConstructor Quit = ("exit ziwnrmill", quitEvent)
+globalEventHandlerConstructor Hush = ("stop playing sound", hushEvent)
+globalEventHandlerConstructor Panic = ("stop playing sound immediately", panicEvent)
+globalEventHandlerConstructor (CustomAction x) = ("execute custom action", customActionEvent x)
+
+globalEventHandlers :: KeyConfig GlobalAction -> [KeyEventHandler GlobalAction (EventM Name AppState)]
+globalEventHandlers conf = map (\a -> toEventHandler a (globalEventHandlerConstructor a)) as
+ where
+ toEventHandler a (t, ev) = onEvent a t ev
+ as = map snd $ keyEventsList $ keyConfigEvents conf
+
+globalKeyDispatcher :: KeyConfig GlobalAction -> KeyDispatcher GlobalAction (EventM Name AppState)
+globalKeyDispatcher conf = case keyDispatcher conf (globalEventHandlers conf) of
+ Left err -> error $ show (map fst err)
+ Right dis -> dis
diff --git a/app/zwirnmill/UI/Window.hs b/app/zwirnmill/UI/Window.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnmill/UI/Window.hs
@@ -0,0 +1,224 @@
+module UI.Window where
+
+import Animation (changeAnimation, changeFramerate, toggleAnimation)
+import Brick (EventM, Extent (..), Location (..), Viewport (..), lookupExtent, lookupViewport)
+import Config (getConfigPath, getKeymapPath, setBootPath, setSamplePath)
+import Control.Monad (forM_)
+import Control.Monad.RWS
+import qualified Data.ByteString.Lazy.UTF8 as BL
+import Data.List ((!?))
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Data.Text.Zipper (textZipper)
+import Docs.Event (copyCodeEvent, evalCodeEvent, gotoLink, gotoStart)
+import Editor.Core (esFilePath, esZipper, newEditor)
+import Editor.Cursor (moveCursorFileStart, moveCursorPos)
+import Editor.Selection (extendSelectionTo)
+import Editor.Util (currentCursor, lineNumberWidth)
+import Keyboard.Event (selectSound)
+import Lens.Micro ((&), (.~), (?~))
+import SampleBrowser.Event (sampleBrowserClickAction)
+import Session (quitEvent)
+import System.File.OsPath as F
+import System.OsPath (decodeFS)
+import UI.Core
+
+rightClickWindow :: Name -> (Int, Int) -> EventM Name AppState ()
+rightClickWindow name (cx, cy) = do
+ (mx, my) <- getAbsolutePos (name, parentWindow name) (cx, cy)
+ os <- getWindowOptions name
+ let opt = OptionWindow (mx, my) name os
+ modify $ \as -> as {asOptionWindow = Just opt}
+
+clickOptionWindow :: (Int, Int) -> EventM Name AppState ()
+clickOptionWindow (_, my) = do
+ mos <- gets asOptionWindow
+ case mos of
+ Nothing -> return ()
+ Just (OptionWindow p name os) -> forM_ (os !? my) (executeOption name p) >> closeOptions
+
+clickWindow :: Name -> (Int, Int) -> EventM Name AppState ()
+clickWindow name (cx, cy) = do
+ (mx, my) <- getParentCoords name (cx, cy)
+ wm <- gets asWindows
+ case Map.lookup (parentWindow name) wm of
+ Nothing -> return ()
+ Just win@(Window _ (sx, sy) _ _ _) -> do
+ newWindow <- contentClickAction (name, win) (mx, my)
+ modify $ \as -> as {asDragging = Just ((mx, my), name, action), asWindows = Map.insert (parentWindow name) newWindow wm}
+ where
+ action
+ | mx /= cx || my /= cy = Content
+ | mx == sx - 1 && my == sy - 1 = ResizeBoth
+ | mx == sx - 1 = ResizeRight
+ | my == sy - 1 = ResizeBottom
+ | mx == 0 || my == 0 = Move
+ | otherwise = Content
+
+dragWindow :: Name -> (Int, Int) -> (Int, Int) -> DragAction -> EventM Name AppState ()
+dragWindow name (ax, ay) _ Content = do
+ wm <- gets asWindows
+ case Map.lookup (parentWindow name) wm of
+ Just win -> do
+ win' <- contentDragAction (name, win) (ax, ay)
+ modify $ \as -> as {asWindows = Map.insert (parentWindow name) win' wm}
+ Nothing -> return ()
+dragWindow name (ax, ay) (lx, ly) Move = do
+ wm <- gets asWindows
+ modify $ \as -> as {asWindows = Map.adjust (\(Window _ s c h l) -> Window (ax - lx, ay - ly) s c h l) name wm}
+dragWindow name (_, ay) _ ResizeBottom = do
+ wm <- gets asWindows
+ modify $ \as -> as {asWindows = Map.adjust (\(Window (px, py) (sx, _) c h l) -> Window (px, py) (sx, ay - py) c h l) name wm}
+dragWindow name (ax, _) _ ResizeRight = do
+ wm <- gets asWindows
+ modify $ \as -> as {asWindows = Map.adjust (\(Window (px, py) (_, sy) c h l) -> Window (px, py) (ax - px, sy) c h l) name wm}
+dragWindow name (ax, ay) _ ResizeBoth = do
+ wm <- gets asWindows
+ modify $ \as -> as {asWindows = Map.adjust (\(Window (px, py) _ c h l) -> Window (px, py) (ax - px, ay - py) c h l) name wm}
+
+getAbsolutePos :: (Name, Name) -> (Int, Int) -> EventM Name AppState (Int, Int)
+getAbsolutePos (name, dragged) c
+ | name == dragged = do
+ wm <- gets asWindows
+ (mx, my) <- getParentCoords name c
+ case Map.lookup (parentWindow name) wm of
+ Just (Window (px, py) _ _ _ _) -> return (px + mx, py + my)
+ Nothing -> return (mx, my)
+ | otherwise = do
+ wm <- gets asWindows
+ (mx, my) <- getParentCoords name c
+ doff <- viewportOffset dragged
+ off <- viewportOffset name
+ case Map.lookup (parentWindow name) wm of
+ Just (Window (px, py) _ _ _ _) -> return (px + mx, py + my + doff - off)
+ Nothing -> return (mx, my + doff)
+
+viewportOffset :: Name -> EventM Name AppState Int
+viewportOffset name = do
+ mvp <- lookupViewport name
+ return $ maybe 0 (\(VP _ x _ _) -> x) mvp
+
+parentWindow :: Name -> Name
+parentWindow (EditorViewport i) = Editor i
+parentWindow DocViewport = Documentation
+parentWindow (DocLink _) = Documentation
+parentWindow (DocCode _) = Documentation
+parentWindow SampleBrowserViewport = SampleBrowser
+parentWindow EnvBrowserViewport = EnvBrowser
+parentWindow x = x
+
+getParentCoords :: Name -> (Int, Int) -> EventM Name AppState (Int, Int)
+getParentCoords name (mx, my) = do
+ (cx, cy) <- maybe (0, 0) (\(Extent _ (Location u) _) -> u) <$> lookupExtent name
+ (px, py) <- maybe (0, 0) (\(Extent _ (Location u) _) -> u) <$> lookupExtent (parentWindow name)
+ return (mx + cx - px, my + cy - py)
+
+contentClickAction :: (Name, Window) -> (Int, Int) -> EventM Name AppState Window
+contentClickAction (Editor i, Window p s (EditorContent es) h l) (mx, my) = do
+ mvp <- lookupViewport (EditorViewport i)
+ let ro = maybe 0 (\(VP _ x _ _) -> x) mvp
+ return $ Window p s (EditorContent $ moveCursorPos (my + ro - 1, mx - lineNumberWidth es) es) h l
+contentClickAction (EditorViewport _, Window p s (EditorContent es) h l) (mx, my) = return $ Window p s (EditorContent $ moveCursorPos (my - 1, mx - lineNumberWidth es) es) h l
+contentClickAction (DocLink l, Window p s (DocumentationContent d _ m) h k) _ = gotoLink d l m >>= \(d', f) -> return (Window p s (DocumentationContent d' f m) h k)
+contentClickAction (DocCode i, Window p s (DocumentationContent d _ m) h k) _ = evalCodeEvent d i >>= \(_, f) -> return (Window p s (DocumentationContent d f m) h k)
+contentClickAction (SampleBrowserViewport, Window p s (SampleBrowserContent sb) h k) pos = sampleBrowserClickAction sb pos >>= \sb' -> return (Window p s (SampleBrowserContent sb') h k)
+contentClickAction (_, x) _ = return x
+
+contentDragAction :: (Name, Window) -> (Int, Int) -> EventM Name AppState Window
+contentDragAction (EditorViewport _, Window (px, py) s (EditorContent es) h l) (ax, ay) = return $ Window (px, py) s (EditorContent $ extendSelectionTo (currentCursor $ moveCursorPos (ay - py - 1, ax - px - lineNumberWidth es) es) es) h l
+contentDragAction (Slider i, Window (px, py) (sx, sy) (SliderContent _) h l) (ax, _) = do
+ let new = max 0 $ min 1 $ fromIntegral (ax - px) / fromIntegral sx
+ env <- gets asEnvironment
+ env' <- liftIO $ updateSlider i new env
+ modify (\as -> as {asEnvironment = env'})
+ return $ Window (px, py) (sx, sy) (SliderContent new) h l
+contentDragAction (_, x) _ = return x
+
+executeOption :: Name -> (Int, Int) -> Option -> EventM Name AppState ()
+executeOption name _ Hide = modify (\as -> as {asWindows = Map.adjust (\win -> win {windowHidden = True}) (parentWindow name) $ asWindows as})
+executeOption _ _ (Show name) = modify (\as -> as {asWindows = Map.adjust (\win -> win {windowHidden = False}) (parentWindow name) $ asWindows as})
+executeOption name _ Close = modify (\as -> as {asWindows = Map.delete (parentWindow name) $ asWindows as})
+executeOption _ p AddEditor = addEditorWithFile p Nothing
+executeOption _ _ AddSlider = addSlider
+executeOption _ _ ToggleAnimation = toggleAnimation
+executeOption _ _ ChangeAnimation = changeAnimation
+executeOption _ _ ChangeFramerate = changeFramerate
+executeOption _ _ SetBootPath = setBootPath
+executeOption _ _ SetSamplePath = setSamplePath
+executeOption _ _ QuitMill = quitEvent
+executeOption name _ ToggleLabel = toggleLabel (parentWindow name)
+executeOption (DocCode i) _ Copy = do
+ mw <- Map.lookup Documentation <$> gets asWindows
+ case mw of
+ Just (Window _ _ (DocumentationContent d _ _) _ _) -> copyCodeEvent d i
+ _ -> return ()
+executeOption _ _ GotoStart = gotoStart
+executeOption _ p OpenConfig = openConfig p
+executeOption _ p OpenKeymap = openKeymap p
+executeOption _ _ SelectAction = selectSound
+executeOption _ _ _ = return ()
+
+closeOptions :: EventM Name AppState ()
+closeOptions = modify (\as -> as {asOptionWindow = Nothing})
+
+getWindowOptions :: Name -> EventM Name AppState [Option]
+getWindowOptions name = case parentWindow name of
+ Background -> do
+ hs <- gets $ Map.keys . Map.filter windowHidden . asWindows
+ return $ AddEditor : AddSlider : OpenConfig : OpenKeymap : map Show hs ++ [QuitMill]
+ (Editor _) -> return [Hide, ToggleLabel, Close]
+ (Slider _) -> return [Hide, ToggleLabel, Close]
+ Animator -> return [ToggleAnimation, ChangeAnimation, ChangeFramerate, Hide, ToggleLabel]
+ Status -> return [SetBootPath, Hide, ToggleLabel]
+ SampleBrowser -> return [SetSamplePath, Hide, ToggleLabel]
+ Keyboard -> return [SelectAction, Hide, ToggleLabel]
+ Documentation -> case name of
+ DocCode _ -> return [Copy]
+ _ -> return [GotoStart, Hide, ToggleLabel]
+ _ -> return [Hide, ToggleLabel]
+
+addSlider :: EventM Name AppState ()
+addSlider = do
+ ss <- gets $ (+ 1) . findMaxSlider . map fst . Map.toList . asWindows
+ slider <- newSlider ss
+ modify (\as -> as {asWindows = Map.insert (Slider ss) slider $ asWindows as, asActiveWindow = Slider ss})
+ where
+ findMaxSlider = foldl (\x y -> max x (numbered y)) 0
+ numbered (Slider i) = i
+ numbered _ = 0
+
+toggleLabel :: Name -> EventM Name AppState ()
+toggleLabel name = modify $ \as -> as {asWindows = Map.alter alt name $ asWindows as}
+ where
+ alt (Just win) = Just win {windowLabel = not $ windowLabel win}
+ alt _ = Nothing
+
+addEditorWithFile :: (Int, Int) -> Maybe (FilePath, T.Text) -> EventM Name AppState ()
+addEditorWithFile (mx, my) mfile = do
+ es <- gets $ (+ 1) . findMaxEditor . map fst . Map.toList . asWindows
+ modify (\as -> as {asWindows = Map.insert (Editor es) (Window (mx, my) (40, 20) (EditorContent editor) False False) $ asWindows as, asActiveWindow = Editor es})
+ where
+ editor = case mfile of
+ Just (path, cont) ->
+ newEditor
+ & esZipper .~ textZipper (T.lines cont) Nothing
+ & esFilePath ?~ path
+ & moveCursorFileStart
+ Nothing -> newEditor
+ findMaxEditor = foldl (\x y -> max x (numbered y)) 0
+ numbered (Editor i) = i
+ numbered _ = 0
+
+openConfig :: (Int, Int) -> EventM Name AppState ()
+openConfig (mx, my) = do
+ ospath <- liftIO getConfigPath
+ c <- liftIO $ F.readFile ospath
+ path <- liftIO $ decodeFS ospath
+ addEditorWithFile (mx, my) (Just (path, T.pack $ BL.toString c))
+
+openKeymap :: (Int, Int) -> EventM Name AppState ()
+openKeymap (mx, my) = do
+ ospath <- liftIO getKeymapPath
+ c <- liftIO $ F.readFile ospath
+ path <- liftIO $ decodeFS ospath
+ addEditorWithFile (mx, my) (Just (path, T.pack $ BL.toString c))
diff --git a/app/zwirnzi/CI/Config.hs b/app/zwirnzi/CI/Config.hs
deleted file mode 100644
--- a/app/zwirnzi/CI/Config.hs
+++ /dev/null
@@ -1,191 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
-
-module CI.Config where
-
-{-
- CommandLine.hs - configuration
- Copyright (C) 2023, Martin Gius
-
- This library is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this library. If not, see .
--}
-
-import Conferer as Conf
-import Conferer.Source.CLIArgs as Cli
-import Conferer.Source.Env as Env
-import Conferer.Source.Yaml as Yaml
-import Control.Monad (unless)
-import qualified Data.ByteString.Lazy.UTF8 as BL
-import qualified Data.Text as T
-import GHC.Generics (Generic)
-import qualified Sound.Tidal.Clock as Clock (ClockConfig (..), defaultConfig)
-import System.Directory.OsPath
-import System.File.OsPath as F
-import System.OsPath
-import qualified Zwirn.Language.Compiler as Compiler
-import qualified Zwirn.Stream.Target as Stream
-import qualified Zwirn.Stream.Types as Stream
-
-data ClockConfig = ClockConfig
- { clockConfigQuantum :: Double,
- clockConfigBeatsPerCycle :: Double,
- clockConfigFrameTimespan :: Double,
- clockConfigEnableLink :: Bool,
- clockConfigSkipTicks :: Int,
- clockConfigProcessAhead :: Double
- }
- deriving (Show, Generic)
-
-data TargetConfig = TargetConfig
- { targetConfigName :: T.Text,
- targetConfigOSCPath :: T.Text,
- targetConfigBusOSCPath :: T.Text,
- targetConfigAddress :: String,
- targetConfigPort :: Int,
- targetConfigBusPort :: Maybe Int
- }
- deriving (Show, Generic)
-
-data StreamConfig = StreamConfig
- { streamConfigTargets :: [TargetConfig],
- streamConfigDefaultTarget :: T.Text,
- streamConfigLocalPort :: Int,
- streamConfigPrecision :: Rational,
- streamConfigClock :: ClockConfig
- }
- deriving (Show, Generic)
-
-data CiConfig = CiConfig
- { ciConfigBootPath :: FilePath,
- ciConfigListener :: Bool,
- ciConfigCli :: Bool,
- ciConfigOverwriteBuiltin :: Bool,
- ciConfigDynamicTypes :: Bool
- }
- deriving (Generic)
-
-data FullConfig = FullConfig
- { fullConfigCi :: CiConfig,
- fullConfigClock :: ClockConfig,
- fullConfigStream :: StreamConfig
- }
- deriving (Generic)
-
-instance DefaultConfig TargetConfig where
- configDef = TargetConfig "superdirt" "/dirt/play" "/c_set" "127.0.0.1" 57120 (Just 57110)
-
-instance DefaultConfig CiConfig where
- configDef = CiConfig "" False False False False
-
-instance DefaultConfig StreamConfig where
- configDef = StreamConfig [configDef] "superdirt" 2323 0.005 configDef
-
-instance DefaultConfig ClockConfig where
- configDef = fromClock Clock.defaultConfig
-
-instance DefaultConfig FullConfig where
- configDef = FullConfig configDef configDef configDef
-
-instance FromConfig TargetConfig
-
-instance FromConfig CiConfig
-
-instance FromConfig StreamConfig
-
-instance FromConfig ClockConfig
-
-instance FromConfig FullConfig
-
-getConfig :: IO Conf.Config
-getConfig = do
- home <- getHomeDirectory
- configDirPath <- (home <>) <$> encodeUtf "/.config/zwirnzi/"
- path <- (home <>) <$> encodeUtf "/.config/zwirnzi/config.yaml"
- createDirectoryIfMissing True configDirPath
- exists <- doesFileExist path
- unless exists (F.writeFile path defaultConfigFile)
- decoded <- decodeUtf path
- mkConfig'
- []
- [ Cli.fromConfig,
- Env.fromConfig "zwirnzi",
- Yaml.fromFilePath decoded
- ]
-
-fromClock :: Clock.ClockConfig -> ClockConfig
-fromClock (Clock.ClockConfig a b c d e f) = ClockConfig (realToFrac a) (realToFrac b) c d (fromIntegral e) f
-
-toClock :: ClockConfig -> Clock.ClockConfig
-toClock (ClockConfig a b c d e f) = Clock.ClockConfig (realToFrac a) (realToFrac b) c d (fromIntegral e) f
-
-toTarget :: TargetConfig -> Stream.TargetConfig
-toTarget (TargetConfig a b c d e f) = Stream.TargetConfig a b c d e f
-
-toStream :: StreamConfig -> Stream.StreamConfig
-toStream (StreamConfig a b c d e) = Stream.StreamConfig (map toTarget a) b c d (toClock e)
-
-toCiConfig :: CiConfig -> Compiler.CiConfig
-toCiConfig (CiConfig _ _ _ x y) = Compiler.CiConfig x y
-
-configPath :: IO String
-configPath = do
- home <- getHomeDirectory
- path <- (home <>) <$> encodeUtf "/.config/zwirnzi/config.yaml"
- exists <- doesFileExist path
- decoded <- decodeUtf path
- if exists then return decoded else return "Config file not found!"
-
-resetConfig :: IO String
-resetConfig = do
- home <- getHomeDirectory
- configDirPath <- (home <>) <$> encodeUtf "/.config/zwirnzi/"
- path <- (home <>) <$> encodeUtf "/.config/zwirnzi/config.yaml"
- createDirectoryIfMissing True configDirPath
- F.writeFile path defaultConfigFile
- return "Restored default config."
-
-defaultConfigFile :: BL.ByteString
-defaultConfigFile =
- BL.fromString "ci:"
- <|> " listener: true"
- <|> " bootpath: \"\""
- <|> " overwritebuiltin: false"
- <|> " dynamictypes: false"
- <|> "stream:"
- <|> " targets:"
- <|> " - name: \"superdirt\""
- <|> " oscpath: \"/dirt/play\""
- <|> " busoscpath: \"/c_set\""
- <|> " address: \"127.0.0.1\""
- <|> " port: 57120"
- <|> " busport: 57110"
- <|> " defaulttarget: \"superdirt\""
- <|> " localport: 52323"
- <|> " precision: 0.005"
- <|> " clock:"
- <|> " quantum: 4"
- <|> " beatspercycle: 4"
- <|> " frametimespan: 0.05"
- <|> " enablelink: false"
- <|> " skipticks: 10"
- <|> " processahead: 0.3"
- where
- (<|>) x y = x <> "\n" <> y
-
-getFile :: String -> IO String
-getFile p = do
- path <- encodeUtf p
- f <- F.readFile path
- return $ BL.toString f
diff --git a/app/zwirnzi/CI/ConfigDoux.hs b/app/zwirnzi/CI/ConfigDoux.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/ConfigDoux.hs
@@ -0,0 +1,201 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module CI.ConfigDoux where
+
+import Conferer (fetch, mkConfig')
+import Conferer.Config ((/.))
+import Conferer.FromConfig (DefaultConfig (..))
+import qualified Conferer.FromConfig as Conf
+import qualified Conferer.Source.CLIArgs as Cli
+import qualified Conferer.Source.Env as Env
+import qualified Conferer.Source.Yaml as Yaml
+import Control.Monad (unless)
+import qualified Data.ByteString.Lazy.UTF8 as BL
+import Data.Maybe (fromMaybe)
+import Data.Ratio ((%))
+import qualified Data.Text as T
+import Data.Yaml (ToJSON (..), encodeFile, object, (.=))
+import System.Directory.OsPath
+import System.File.OsPath as F
+import System.OsPath
+import Zwirn.Doux.Types (defaultDouxClockConfig)
+import qualified Zwirn.Doux.Types as Stream
+import Zwirn.Language (StreamType (Doux))
+import Zwirn.Language.Compiler (CIError (..), Environment (..), compilerInterpreterBoot, runCI)
+import qualified Zwirn.Language.Compiler as Compiler
+import Prelude hiding (log)
+
+data StreamConfig = StreamConfig
+ { streamConfigSamples :: Maybe FilePath,
+ streamConfigInput :: Maybe String,
+ streamConfigOutput :: Maybe String,
+ streamConfigHost :: Maybe String,
+ streamConfigBufferSize :: Int,
+ streamConfigChannels :: Int,
+ streamConfigBlockSize :: Int,
+ streamConfigMaxVoices :: Int
+ }
+ deriving (Show)
+
+data CiConfig = CiConfig
+ { ciConfigBootPath :: FilePath,
+ ciConfigCli :: Bool,
+ ciConfigOverwriteBuiltin :: Bool,
+ ciConfigDynamicTypes :: Bool,
+ ciConfigPrecision :: Int
+ }
+ deriving (Show)
+
+data FullConfig = FullConfig
+ { fullConfigCi :: CiConfig,
+ fullConfigStream :: StreamConfig
+ }
+ deriving (Show)
+
+instance DefaultConfig CiConfig where
+ configDef = CiConfig "" False False False 200
+
+instance DefaultConfig StreamConfig where
+ configDef = StreamConfig Nothing Nothing Nothing Nothing 256 2 32 32
+
+instance DefaultConfig FullConfig where
+ configDef = FullConfig configDef configDef
+
+instance Conf.FromConfig StreamConfig where
+ fromConfig key configSource = do
+ path <- Conf.fetchFromConfig (key /. "samples") configSource
+ input <- Conf.fetchFromConfig (key /. "input") configSource
+ output <- Conf.fetchFromConfig (key /. "output") configSource
+ host <- Conf.fetchFromConfig (key /. "host") configSource
+ bs <- Conf.fetchFromConfig (key /. "buffersize") configSource
+ cs <- Conf.fetchFromConfig (key /. "channels") configSource
+ bl <- Conf.fetchFromConfig (key /. "blocksize") configSource
+ mx <- Conf.fetchFromConfig (key /. "maxvoices") configSource
+ return $ StreamConfig path input output host (fromMaybe 256 bs) (fromMaybe 2 cs) (fromMaybe 32 bl) (fromMaybe 32 mx)
+
+instance Conf.FromConfig CiConfig where
+ fromConfig key configSource = do
+ path <- Conf.fetchFromConfig (key /. "bootpath") configSource
+ cli <- Conf.fetchFromConfig (key /. "cli") configSource
+ bp <- Conf.fetchFromConfig (key /. "overwritebuiltin") configSource
+ dt <- Conf.fetchFromConfig (key /. "dynamictypes") configSource
+ prec <- Conf.fetchFromConfig (key /. "precision") configSource
+ return $ CiConfig (fromMaybe "" path) (fromMaybe False cli) (fromMaybe False bp) (fromMaybe False dt) (fromMaybe 200 prec)
+
+instance Conf.FromConfig FullConfig where
+ fromConfig key configSource = do
+ ci <- Conf.fetchFromConfig (key /. "ci") configSource
+ str <- Conf.fetchFromConfig (key /. "stream") configSource
+ return $ FullConfig ci (fromMaybe configDef str)
+
+instance ToJSON CiConfig where
+ toJSON (CiConfig p cli o d prec) =
+ object
+ [ "bootpath" .= p,
+ "cli" .= cli,
+ "overwritebuiltin" .= o,
+ "dynamictypes" .= d,
+ "precision" .= prec
+ ]
+
+instance ToJSON StreamConfig where
+ toJSON (StreamConfig sam inp out host buf chan block maxv) =
+ object
+ [ "samples" .= sam,
+ "host" .= host,
+ "input" .= inp,
+ "output" .= out,
+ "buffersize" .= buf,
+ "channels" .= chan,
+ "blocksize" .= block,
+ "maxvoices" .= maxv
+ ]
+
+instance ToJSON FullConfig where
+ toJSON (FullConfig ci str) =
+ object
+ [ "ci" .= toJSON ci,
+ "stream" .= toJSON str
+ ]
+
+getConfigPath :: IO OsPath
+getConfigPath = do
+ appname <- encodeUtf "zwirnzi"
+ configname <- encodeUtf "config-doux.yaml"
+ configDirPath <- getXdgDirectory XdgConfig appname
+ let path = configDirPath configname
+ createDirectoryIfMissing True configDirPath
+ return path
+
+getConfig :: IO FullConfig
+getConfig = do
+ path <- getConfigPath
+ exists <- doesFileExist path
+ unless exists encodeDefault
+ decoded <- decodeUtf path
+ conf <-
+ mkConfig'
+ []
+ [ Cli.fromConfig,
+ Env.fromConfig "zwirnzi",
+ Yaml.fromFilePath decoded
+ ]
+ fetch conf
+
+toStream :: Rational -> StreamConfig -> Stream.StreamConfig
+toStream prec (StreamConfig a b c d e f g h) = Stream.StreamConfig prec a b c d e f g h defaultDouxClockConfig
+
+toCiConfig :: CiConfig -> Compiler.CiConfig
+toCiConfig (CiConfig _ _ x y z) = Compiler.CiConfig x y (1 % fromIntegral z) Doux
+
+configPath :: IO String
+configPath = do
+ path <- getConfigPath
+ exists <- doesFileExist path
+ decoded <- decodeUtf path
+ if exists then return decoded else return "Config file not found!"
+
+resetConfig :: IO String
+resetConfig = encodeDefault >> return "Restored default config."
+
+encodeDefault :: IO ()
+encodeDefault = encodeConfig configDef
+
+encodeConfig :: FullConfig -> IO ()
+encodeConfig conf = do
+ path <- getConfigPath
+ strp <- decodeFS path
+ encodeFile strp $ toJSON conf
+
+getFile :: String -> IO String
+getFile p = do
+ path <- encodeUtf p
+ f <- F.readFile path
+ return $ BL.toString f
+
+checkBoot :: (String -> IO ()) -> FilePath -> Environment -> IO (Maybe Environment)
+checkBoot log "" _ = log "Starting without Bootfile." >> return Nothing
+checkBoot log path env = do
+ ospath <- encodeUtf path
+ isfile <- doesFileExist ospath
+ ps <-
+ if isfile
+ then return $ decodeUtf ospath
+ else do
+ isfolder <- doesDirectoryExist ospath
+ if isfolder
+ then do
+ pss <- listDirectory ospath
+ fs <- mapM decodeUtf pss
+ return $ map (\f -> path ++ "/" ++ f) fs
+ else return []
+ res <- runCI env (compilerInterpreterBoot $ map T.pack ps)
+ case res of
+ Left (CIError err _) -> log ("Error in Bootfile: " ++ show err) >> return Nothing
+ Right newEnv ->
+ if ps /= []
+ then log ("Successfully loaded Bootfiles from " ++ path) >> return (Just newEnv)
+ else log ("No Bootfiles found at " ++ path) >> return Nothing
+
+cliMode :: FullConfig -> Bool
+cliMode = ciConfigCli . fullConfigCi
diff --git a/app/zwirnzi/CI/ConfigSuperDirt.hs b/app/zwirnzi/CI/ConfigSuperDirt.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/ConfigSuperDirt.hs
@@ -0,0 +1,197 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module CI.ConfigSuperDirt where
+
+{-
+ CommandLine.hs - configuration
+ Copyright (C) 2023, Martin Gius
+
+ This library is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this library. If not, see .
+-}
+
+import Conferer as Conf
+import Conferer.Source.CLIArgs as Cli
+import Conferer.Source.Env as Env
+import Conferer.Source.Yaml as Yaml
+import Control.Monad (unless)
+import qualified Data.ByteString.Lazy.UTF8 as BL
+import qualified Data.Text as T
+import GHC.Generics (Generic)
+import qualified Sound.Tidal.Clock as Clock (ClockConfig (..), defaultConfig)
+import System.Directory.OsPath
+import System.File.OsPath as F
+import System.OsPath
+import Zwirn.Language (StreamType (..))
+import qualified Zwirn.Language.Compiler as Compiler
+import qualified Zwirn.Stream.Target as Stream
+import qualified Zwirn.Stream.Types as Stream
+
+data ClockConfig = ClockConfig
+ { clockConfigQuantum :: Double,
+ clockConfigBeatsPerCycle :: Double,
+ clockConfigFrameTimespan :: Double,
+ clockConfigEnableLink :: Bool,
+ clockConfigSkipTicks :: Int,
+ clockConfigProcessAhead :: Double
+ }
+ deriving (Show, Generic)
+
+data TargetConfig = TargetConfig
+ { targetConfigName :: T.Text,
+ targetConfigOSCPath :: T.Text,
+ targetConfigBusOSCPath :: T.Text,
+ targetConfigAddress :: String,
+ targetConfigPort :: Int,
+ targetConfigBusPort :: Maybe Int
+ }
+ deriving (Show, Generic)
+
+data StreamConfig = StreamConfig
+ { streamConfigTargets :: [TargetConfig],
+ streamConfigDefaultTarget :: T.Text,
+ streamConfigLocalPort :: Int,
+ streamConfigClock :: ClockConfig
+ }
+ deriving (Show, Generic)
+
+data CiConfig = CiConfig
+ { ciConfigBootPath :: FilePath,
+ ciConfigListener :: Bool,
+ ciConfigCli :: Bool,
+ ciConfigOverwriteBuiltin :: Bool,
+ ciConfigDynamicTypes :: Bool,
+ ciConfigPrecision :: Rational
+ }
+ deriving (Generic)
+
+data FullConfig = FullConfig
+ { fullConfigCi :: CiConfig,
+ fullConfigClock :: ClockConfig,
+ fullConfigStream :: StreamConfig
+ }
+ deriving (Generic)
+
+instance DefaultConfig TargetConfig where
+ configDef = TargetConfig "superdirt" "/dirt/play" "/c_set" "127.0.0.1" 57120 (Just 57110)
+
+instance DefaultConfig CiConfig where
+ configDef = CiConfig "" False False False False 0.005
+
+instance DefaultConfig StreamConfig where
+ configDef = StreamConfig [configDef] "superdirt" 2323 configDef
+
+instance DefaultConfig ClockConfig where
+ configDef = fromClock Clock.defaultConfig
+
+instance DefaultConfig FullConfig where
+ configDef = FullConfig configDef configDef configDef
+
+instance FromConfig TargetConfig
+
+instance FromConfig CiConfig
+
+instance FromConfig StreamConfig
+
+instance FromConfig ClockConfig
+
+instance FromConfig FullConfig
+
+getConfig :: IO FullConfig
+getConfig = do
+ home <- getHomeDirectory
+ configDirPath <- (home <>) <$> encodeUtf "/.config/zwirnzi/"
+ path <- (home <>) <$> encodeUtf "/.config/zwirnzi/config.yaml"
+ createDirectoryIfMissing True configDirPath
+ exists <- doesFileExist path
+ unless exists (F.writeFile path defaultConfigFile)
+ decoded <- decodeUtf path
+ conf <-
+ mkConfig'
+ []
+ [ Cli.fromConfig,
+ Env.fromConfig "zwirnzi",
+ Yaml.fromFilePath decoded
+ ]
+ fetch conf
+
+fromClock :: Clock.ClockConfig -> ClockConfig
+fromClock (Clock.ClockConfig a b c d e f) = ClockConfig (realToFrac a) (realToFrac b) c d (fromIntegral e) f
+
+toClock :: ClockConfig -> Clock.ClockConfig
+toClock (ClockConfig a b c d e f) = Clock.ClockConfig (realToFrac a) (realToFrac b) c d (fromIntegral e) f
+
+toTarget :: TargetConfig -> Stream.TargetConfig
+toTarget (TargetConfig a b c d e f) = Stream.TargetConfig a b c d e f
+
+toStream :: Rational -> StreamConfig -> Stream.StreamConfig
+toStream prec (StreamConfig a b c d) = Stream.StreamConfig (map toTarget a) b c prec (toClock d)
+
+toCiConfig :: CiConfig -> Compiler.CiConfig
+toCiConfig (CiConfig _ _ _ x y z) = Compiler.CiConfig x y z SuperDirt
+
+configPath :: IO String
+configPath = do
+ home <- getHomeDirectory
+ path <- (home <>) <$> encodeUtf "/.config/zwirnzi/config.yaml"
+ exists <- doesFileExist path
+ decoded <- decodeUtf path
+ if exists then return decoded else return "Config file not found!"
+
+resetConfig :: IO String
+resetConfig = do
+ home <- getHomeDirectory
+ configDirPath <- (home <>) <$> encodeUtf "/.config/zwirnzi/"
+ path <- (home <>) <$> encodeUtf "/.config/zwirnzi/config.yaml"
+ createDirectoryIfMissing True configDirPath
+ F.writeFile path defaultConfigFile
+ return "Restored default config."
+
+defaultConfigFile :: BL.ByteString
+defaultConfigFile =
+ BL.fromString "ci:"
+ <|> " listener: true"
+ <|> " bootpath: \"\""
+ <|> " overwritebuiltin: false"
+ <|> " dynamictypes: false"
+ <|> " precision: 0.005"
+ <|> "stream:"
+ <|> " targets:"
+ <|> " - name: \"superdirt\""
+ <|> " oscpath: \"/dirt/play\""
+ <|> " busoscpath: \"/c_set\""
+ <|> " address: \"127.0.0.1\""
+ <|> " port: 57120"
+ <|> " busport: 57110"
+ <|> " defaulttarget: \"superdirt\""
+ <|> " localport: 2323"
+ <|> " clock:"
+ <|> " quantum: 4"
+ <|> " beatspercycle: 4"
+ <|> " frametimespan: 0.05"
+ <|> " enablelink: false"
+ <|> " skipticks: 10"
+ <|> " processahead: 0.3"
+ where
+ (<|>) x y = x <> "\n" <> y
+
+getFile :: String -> IO String
+getFile p = do
+ path <- encodeUtf p
+ f <- F.readFile path
+ return $ BL.toString f
+
+cliMode :: FullConfig -> Bool
+cliMode = ciConfigCli . fullConfigCi
diff --git a/app/zwirnzi/CI/Setup.hs b/app/zwirnzi/CI/Setup.hs
deleted file mode 100644
--- a/app/zwirnzi/CI/Setup.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-module CI.Setup (setup) where
-
-{-
- Setup.hs - setup of the various components of the backend
- Copyright (C) 2023, Martin Gius
-
- This library is free software: you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation, either version 3 of the License, or
- (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this library. If not, see .
--}
-
-import CI.Config as C
-import Control.Concurrent (forkIO)
-import Control.Monad (void, when)
-import qualified Data.Map as Map
-import qualified Data.Text as T
-import System.Directory.OsPath
-import System.IO (hPutStrLn, stderr)
-import System.OsPath
-import Zwirn.Language.Builtin.Prelude
-import Zwirn.Language.Compiler as Compiler
-import Zwirn.Language.Macro (defaultMacroMap)
-import Zwirn.Stream.Handshake (sendHandshake)
-import Zwirn.Stream.Listen
-import Zwirn.Stream.Target (Target (..))
-import Zwirn.Stream.Types
-import Zwirn.Stream.UI
-
-setup :: FullConfig -> IO Environment
-setup config = do
- str <- setupStream config
- when (ciConfigListener $ fullConfigCi config) (setupListener str)
- let initE = getInitialEnv (toCiConfig $ fullConfigCi config) str
- checkBoot (fullConfigCi config) initE
-
-setupStream :: FullConfig -> IO Stream
-setupStream config = startStream (toStream $ fullConfigStream config)
-
-setupListener :: Stream -> IO ()
-setupListener str = do
- case Map.lookup "superdirt" (sTargetMap str) of
- Nothing -> return ()
- Just (Target _ _ addr _) -> sendHandshake (sLocal str) addr
- void (forkIO $ listen str)
-
-getInitialEnv :: Compiler.CiConfig -> Stream -> Environment
-getInitialEnv config str = Environment str (builtinEnvironmentWithStream str) (Just $ ConfigEnv configPath resetConfig) config defaultMacroMap
-
-checkBoot :: C.CiConfig -> Environment -> IO Environment
-checkBoot (C.CiConfig "" _ _ _ _) env = hPutStrLn stderr "Starting without Bootfile." >> return env
-checkBoot (C.CiConfig path _ _ _ _) env = do
- ospath <- encodeUtf path
- isfile <- doesFileExist ospath
- ps <-
- if isfile
- then return $ decodeUtf ospath
- else do
- isfolder <- doesDirectoryExist ospath
- if isfolder
- then do
- pss <- listDirectory ospath
- fs <- mapM decodeUtf pss
- return $ map (\f -> path ++ "/" ++ f) fs
- else return []
- res <- runCI env (compilerInterpreterBoot $ map T.pack ps)
- case res of
- Left (CIError err newEnv) -> hPutStrLn stderr ("Error in Bootfile: " ++ show err) >> return newEnv
- Right newEnv ->
- if ps /= []
- then hPutStrLn stderr ("Successfully loaded Bootfiles from " ++ path) >> return newEnv
- else hPutStrLn stderr ("No Bootfiles found at " ++ path) >> return newEnv
diff --git a/app/zwirnzi/CI/SetupDoux.hs b/app/zwirnzi/CI/SetupDoux.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/SetupDoux.hs
@@ -0,0 +1,23 @@
+module CI.SetupDoux where
+
+import CI.ConfigDoux as C
+import Data.Maybe (fromMaybe)
+import Data.Ratio ((%))
+import Zwirn.Doux.Env
+import Zwirn.Doux.Types (Stream (..))
+import Zwirn.Doux.UI
+import Zwirn.Language.Compiler as Compiler
+import Zwirn.Language.Macro (defaultMacroMap)
+import Prelude hiding (log)
+
+setup :: FullConfig -> IO Environment
+setup config = do
+ str <- setupStream config
+ let initE = getInitialEnv (toCiConfig $ fullConfigCi config) str
+ fromMaybe initE <$> checkBoot print (ciConfigBootPath $ fullConfigCi config) initE
+
+setupStream :: FullConfig -> IO Stream
+setupStream config = startStream (toStream (1 % fromIntegral (C.ciConfigPrecision $ fullConfigCi config)) $ fullConfigStream config)
+
+getInitialEnv :: Compiler.CiConfig -> Stream -> Environment
+getInitialEnv config str = Environment (sState str) (playEnvFromStream str) (builtinEnvironmentWithStream str) (Just $ ConfigEnv configPath resetConfig) config defaultMacroMap
diff --git a/app/zwirnzi/CI/SetupSuperDirt.hs b/app/zwirnzi/CI/SetupSuperDirt.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/SetupSuperDirt.hs
@@ -0,0 +1,80 @@
+module CI.SetupSuperDirt (setup) where
+
+{-
+ Setup.hs - setup of the various components of the backend
+ Copyright (C) 2023, Martin Gius
+
+ This library is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this library. If not, see .
+-}
+
+import CI.ConfigSuperDirt as C
+import Control.Concurrent (forkIO)
+import Control.Monad (void, when)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import System.Directory.OsPath
+import System.IO (hPutStrLn, stderr)
+import System.OsPath
+import Zwirn.Language.Compiler as Compiler
+import Zwirn.Language.Macro (defaultMacroMap)
+import Zwirn.Stream.Env (builtinEnvironmentWithStream, playEnvFromStream)
+import Zwirn.Stream.Handshake (sendHandshake)
+import Zwirn.Stream.Listen
+import Zwirn.Stream.Target (Target (..))
+import Zwirn.Stream.Types
+import Zwirn.Stream.UI
+
+setup :: FullConfig -> IO Environment
+setup config = do
+ str <- setupStream config
+ when (ciConfigListener $ fullConfigCi config) (setupListener str)
+ let initE = getInitialEnv (toCiConfig $ fullConfigCi config) str
+ checkBoot (fullConfigCi config) initE
+
+setupStream :: FullConfig -> IO Stream
+setupStream config = startStream (toStream (C.ciConfigPrecision $ fullConfigCi config) $ fullConfigStream config)
+
+setupListener :: Stream -> IO ()
+setupListener str = do
+ case Map.lookup "superdirt" (sTargetMap str) of
+ Nothing -> return ()
+ Just (Target _ _ addr _) -> sendHandshake (sLocal str) addr
+ void (forkIO $ listen str)
+
+getInitialEnv :: Compiler.CiConfig -> Stream -> Environment
+getInitialEnv config str = Environment (sState str) (playEnvFromStream str) (builtinEnvironmentWithStream str) (Just $ ConfigEnv configPath resetConfig) config defaultMacroMap
+
+checkBoot :: C.CiConfig -> Environment -> IO Environment
+checkBoot (C.CiConfig "" _ _ _ _ _) env = hPutStrLn stderr "Starting without Bootfile." >> return env
+checkBoot (C.CiConfig path _ _ _ _ _) env = do
+ ospath <- encodeUtf path
+ isfile <- doesFileExist ospath
+ ps <-
+ if isfile
+ then return $ decodeUtf ospath
+ else do
+ isfolder <- doesDirectoryExist ospath
+ if isfolder
+ then do
+ pss <- listDirectory ospath
+ fs <- mapM decodeUtf pss
+ return $ map (\f -> path ++ "/" ++ f) fs
+ else return []
+ res <- runCI env (compilerInterpreterBoot $ map T.pack ps)
+ case res of
+ Left (CIError err newEnv) -> hPutStrLn stderr ("Error in Bootfile: " ++ show err) >> return newEnv
+ Right newEnv ->
+ if ps /= []
+ then hPutStrLn stderr ("Successfully loaded Bootfiles from " ++ path) >> return newEnv
+ else hPutStrLn stderr ("No Bootfiles found at " ++ path) >> return newEnv
diff --git a/app/zwirnzi/LSP/Handlers/Command.hs b/app/zwirnzi/LSP/Handlers/Command.hs
--- a/app/zwirnzi/LSP/Handlers/Command.hs
+++ b/app/zwirnzi/LSP/Handlers/Command.hs
@@ -41,7 +41,7 @@
doc = LSP.toNormalizedUri uri
mdoc <- getVirtualFile doc
case mdoc of
- Just vf@(VirtualFile _ version _) -> do
+ Just vf@(VirtualFile _ version _ _) -> do
mci <- liftIO $ runCI env (evalBlockAt (virtualFileText vf) ((\(LSP.Position l _) -> fromIntegral l) begin))
case mci of
Right ((edits, msgs), newEnv) -> do
diff --git a/app/zwirnzi/LSP/Handlers/File.hs b/app/zwirnzi/LSP/Handlers/File.hs
--- a/app/zwirnzi/LSP/Handlers/File.hs
+++ b/app/zwirnzi/LSP/Handlers/File.hs
@@ -46,7 +46,7 @@
let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri
mdoc <- getVirtualFile doc
case mdoc of
- Just vf@(VirtualFile _ version _rope) -> do
+ Just vf@(VirtualFile _ version _rope _) -> do
env <- liftIO $ readMVar envMV
errs <- liftIO $ validateCode env (virtualFileText vf)
case errs of
diff --git a/app/zwirnzi/LSP/Handlers/Hover.hs b/app/zwirnzi/LSP/Handlers/Hover.hs
--- a/app/zwirnzi/LSP/Handlers/Hover.hs
+++ b/app/zwirnzi/LSP/Handlers/Hover.hs
@@ -23,7 +23,7 @@
env <- liftIO $ readMVar envMV
case mdoc of
Just vf -> do
- mci <- liftIO $ runCI env (parseAndGetInfoAt (virtualFileText vf) pos)
+ mci <- liftIO $ runCI env (parseAndGetInfoAt True (virtualFileText vf) pos)
case mci of
Right (Just (info, rng)) -> responder . Right . LSP.maybeToNull $ Just $ LSP.Hover (LSP.InL $ LSP.mkMarkdown info) (Just (toLSP rng))
_ -> return ()
diff --git a/app/zwirnzi/Main.hs b/app/zwirnzi/Main.hs
--- a/app/zwirnzi/Main.hs
+++ b/app/zwirnzi/Main.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
module Main where
{-
@@ -19,9 +21,13 @@
-}
import CI.Backend
-import CI.Config
-import CI.Setup
-import Conferer as Conf
+#if STREAM_SUPERDIRT
+import qualified CI.ConfigSuperDirt as Config
+import qualified CI.SetupSuperDirt as Setup
+#else
+import qualified CI.ConfigDoux as Config
+import qualified CI.SetupDoux as Setup
+#endif
import Control.Concurrent.MVar
import Control.Monad (void)
import qualified LSP.Main as LSP
@@ -31,17 +37,13 @@
main = do
hSetBuffering stdin NoBuffering
- config <- getConfig
- fullConfig <- Conf.fetch config
- env <- setup fullConfig
+ fullConfig <- Config.getConfig
+ env <- Setup.setup fullConfig
envMV <- newMVar env
- if cliMode fullConfig
+ if Config.cliMode fullConfig
then do
hSetBuffering stdout NoBuffering
runZwirnCI env evalInputLoop
else do
hSetBuffering stdout LineBuffering
void $ LSP.main envMV
-
-cliMode :: FullConfig -> Bool
-cliMode = ciConfigCli . fullConfigCi
diff --git a/docs/reference/time.md b/docs/reference/time.md
new file mode 100644
--- /dev/null
+++ b/docs/reference/time.md
@@ -0,0 +1,92 @@
+**Functions manipulating time**
+
+**fast** `:: Number -> a -> a`
+
+*fast* speeds up patterns by a given amount. For example, `fast 2 x` will make `x` twice as fast.
+If the amount is less than one, it will slow down instead. Negative amounts will reverse time additionaly.
+
+equivalences:
+`fast n x == x*n`
+`fast (1 |/ n) x == slow n x`
+`fast -1 x == rev x`
+
+examples:
+```
+1 $: fast [2 4] kick
+```
+```
+1 $: [kick (fast 2 snare) ~ hat]
+```
+```
+1 $: fast <2 -2> [kick snare ~ hat]
+```
+
+**slow** `:: Number -> a -> a`
+
+*slow* slows down patterns by a given amount. For example, `slow 2 x` will make `x` twice as slow.
+If the amount is less than one, it will speed up instead. Negative amounts will reverse time additionaly.
+
+equivalences:
+`slow n x == x/n`
+`slow (1 |/ n) x == fast n x`
+`slow -1 x == rev x`
+
+examples:
+```
+1 $: slow 1.5 [kick snare hat]
+```
+
+**shift** `:: Number -> a -> a`
+
+*shift* shifts patterns by a given amount. Positive amounts shift to the left, making events occur *later*
+Negative amounts shift to the right, making events occur *sooner*.
+
+equivalences:
+`shift n x == x+n`
+
+examples:
+```
+1 $: [kick snare kick+0.5 snare]
+```
+
+
+**ply** `:: Number -> a -> a`
+
+*ply* speeds up the inner structure of patterns by a given amount, resulting in repetitions of events.
+
+examples:
+```
+1 $: ply 2 [kick snare ~ hat]
+```
+
+**bump** `:: Number -> a -> a`
+
+*bump* shifts the inner structure of patterns by a given amount.
+
+examples:
+```
+1 $: [(bump 0.25 [kick snare]), hat*4]
+```
+
+**rev** `:: a -> a`
+
+*rev* reverses a pattern.
+
+equivalences:
+`rev x == slow -1 x`
+`rev x == fast -1 x`
+
+examples:
+```
+1 $: [kick snare ~ hat]
+```
+
+**revBy** `:: Number -> a -> a`
+
+*revBy* reverses a certain part of a pattern.
+
+examples:
+```
+1 $: revBy <0 0.25 0.5 0.75>
+ $ [kick [hat hat] snare clap]
+```
diff --git a/docs/sidebar/overview.md b/docs/sidebar/overview.md
new file mode 100644
--- /dev/null
+++ b/docs/sidebar/overview.md
@@ -0,0 +1,4 @@
+[Welcome](welcome.md)
+
+**Tutorial**
+ [First Sounds](tutorial/start.md)
diff --git a/docs/sidebar/reference.md b/docs/sidebar/reference.md
new file mode 100644
--- /dev/null
+++ b/docs/sidebar/reference.md
@@ -0,0 +1,3 @@
+Reference
+
+ [Functions Manipulating Time](reference/time.md)
diff --git a/docs/tutorial/start.md b/docs/tutorial/start.md
new file mode 100644
--- /dev/null
+++ b/docs/tutorial/start.md
@@ -0,0 +1,59 @@
+**First Sounds with Zwirn**
+
+This tutorial will slowly walk you through how to make sounds with zwirn.
+The code blocks in this tutorial are all runnable by clicking them.
+You can also copy the code with **Ctrl+C**, or by right clicking the code block.
+
+To run some code in the editor you navigate with the cursor to the code you want to run and press **Ctrl+ENTER** - if that doesn't seem to do anything try **Alt+ENTER**!
+
+Let's try it out with the following code
+```
+1 $: s "kick"
+```
+
+By clicking the code block, you should be able to hear a kick drum sound looping.
+To stop the sound you can run
+```
+hush
+```
+
+For convenience, hush has its own shortcut - by default Alt+.
+Try it out for yourself by running the kick drum again!
+
+Let's break down what the code is actually doing:
+
+- the *1* stands for the channel that is in charge of playing the sound,
+- the *s* stands for sound and expects a text as input, which in this case is `"kick"`
+
+to switch the kick drum sound with a snare drum sound we can write `"snare"` instead of `"kick"`
+
+What sounds are available depends on the underlying sound engine, called doux. For now, here are some sources you can try out: `"kick"`, `"snare"`, `"hat"`, `"tom"`, `"clap"`, `"rim"`, `"sine"`, `"tri"`, `"saw"`
+
+We will see how to load our own samples into doux later.
+
+There are also shorthands for these predefined that allow you to write
+```
+1 $: tom
+```
+
+Now let's make a more complex rhythm. We use `[` `]` to write down sequences, for example
+```
+1 $: [tom tom snare]
+```
+Notice how this led to the rhythm speeding up. This is because sequences are always relative tothe main unit called a *cycle*. To illustrate, we can play a sequence of three against four:
+```
+1 $: [tom tom snare]
+2 $: [hat hat hat hat]
+```
+So the more things we put into a sequence, the faster it gets. To leave some space in rhythms we can use a silence, notated as `~`
+```
+1 $: [tom tom snare]
+2 $: [hat hat ~ hat]
+```
+Sequences can also be nested in eachother:
+```
+1 $: [tom [clap tom] snare]
+2 $: [hat hat ~ hat]
+```
+
+[link](reference/time.md)
diff --git a/docs/welcome.md b/docs/welcome.md
new file mode 100644
--- /dev/null
+++ b/docs/welcome.md
@@ -0,0 +1,15 @@
+**Welcome to the Zwirn Documentation!**
+
+Zwirn is a live-coding language in the uzu-family (like Tidal and Strudel).
+A lot of concepts will be familiar if you know one of these languages.
+No problem if you don't though *:-)*
+
+I have been working on Zwirn for the past couple of years and it is slowly getting more mature,
+but please do let me know if you encounter any bugs!!
+
+*Zwirnmill* is a small text user interface to play with Zwirn and it comes bundled with the great
+sound engine Doux. You can read more about Doux here: *https://doux.livecoding.fr/*.
+
+To get started with zwirn you can follow the tutorial by clicking this [link](tutorial/start.md).
+
+If you are looking for a quick reference have a look [here](sidebar/reference.md)
diff --git a/src/zwirn-core/Zwirn/Core/Cord.hs b/src/zwirn-core/Zwirn/Core/Cord.hs
--- a/src/zwirn-core/Zwirn/Core/Cord.hs
+++ b/src/zwirn-core/Zwirn/Core/Cord.hs
@@ -47,9 +47,9 @@
stack :: [Cord st i a] -> Cord st i a
stack zs = zwirn $ \t st -> Branch $ map (\x -> unzwirn x t st) zs
--- | get the current depth of the cord
-depth :: Cord st i a -> Cord st i Int
-depth c = zwirn z
+-- | get the current top length of the cord
+length :: Cord st i a -> Cord st i Int
+length c = zwirn z
where
z t st = pure (Value l t [], st)
where
@@ -61,7 +61,7 @@
_pick i = withInner (look i)
collect :: Cord st i a -> Cord st i [Cord st i a]
-collect c = map (`_pick` c) . enumFromTo 0 . (\x -> x - 1) <$> depth c
+collect c = map (`_pick` c) . enumFromTo 0 . (\x -> x - 1) <$> Zwirn.Core.Cord.length c
_cordmap :: (Cord st i a -> Cord st i b) -> Cord st i a -> Cord st i b
_cordmap f x = (stack . map f) =<< collect x
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Cord.hs b/src/zwirn-core/Zwirn/Core/Lib/Cord.hs
--- a/src/zwirn-core/Zwirn/Core/Lib/Cord.hs
+++ b/src/zwirn-core/Zwirn/Core/Lib/Cord.hs
@@ -31,7 +31,7 @@
import Zwirn.Core.Core
import Zwirn.Core.Lib.Conditional (iff)
import Zwirn.Core.Lib.Core
-import Zwirn.Core.Lib.Modulate (bump, fastcat, fastcyclecatpat, shift)
+import Zwirn.Core.Lib.Modulate (bump, fastcat, fastcyclecatpat, newcat, shift)
import Zwirn.Core.Lib.Number
import Zwirn.Core.Time
import Zwirn.Core.Tree
@@ -39,9 +39,9 @@
import Zwirn.Core.Types
import Prelude hiding (Foldable (..))
--- | get the current depth of the cord
-depth :: Cord st i a -> Cord st i Int
-depth = C.depth
+-- | get the current top length of the cord
+length :: Cord st i a -> Cord st i Int
+length = C.length
superimpose :: Cord st i (Cord st i a -> Cord st i a) -> Cord st i a -> Cord st i a
superimpose f x = stack [apply f x, x]
@@ -68,7 +68,7 @@
select :: Cord st i Double -> Cord st i a -> Cord st i a
select d x = Zwirn.Core.Lib.Cord.pick i x
where
- i = join $ liftA2 (\l k -> if k > 0 && abs l <= 1 then pure $ Prelude.floor $ l * fromIntegral k else silence) d (C.depth x)
+ i = join $ liftA2 (\l k -> if k > 0 && abs l <= 1 then pure $ Prelude.floor $ l * fromIntegral k else silence) d (C.length x)
-- | insert cord a specific index
insert :: Cord st i Int -> Cord st i a -> Cord st i a -> Cord st i a
@@ -106,8 +106,8 @@
rotate iz xz = flip liftList xz . rotateList =<< iz
where
rotateList n xs
- | n > 0 = Prelude.take (length xs) (Prelude.drop n (cycle $ Prelude.reverse xs))
- | otherwise = Prelude.take (length xs) (Prelude.drop n (cycle xs))
+ | n > 0 = Prelude.take (Data.Foldable.length xs) (Prelude.drop n (cycle $ Prelude.reverse xs))
+ | otherwise = Prelude.take (Data.Foldable.length xs) (Prelude.drop n (cycle xs))
take :: Cord st i Int -> Cord st i a -> Cord st i a
take iz xz = flip liftList xz . Prelude.take =<< iz
@@ -130,7 +130,7 @@
open = liftList openList
where
openList ds = case ds of
- (d : _ : _ : _) -> [fmap (first $ fmap (+ (-12))) d, fmap (first $ fmap (+ (-12))) (ds !! 2), ds !! 1] ++ Prelude.reverse (Prelude.take (length ds - 3) (Prelude.reverse ds))
+ (d : _ : _ : _) -> [fmap (first $ fmap (+ (-12))) d, fmap (first $ fmap (+ (-12))) (ds !! 2), ds !! 1] ++ Prelude.reverse (Prelude.take (Data.Foldable.length ds - 3) (Prelude.reverse ds))
_ -> ds
expand :: (Num a) => Cord st i Int -> Cord st i a -> Cord st i a
@@ -161,6 +161,9 @@
cordcat :: Cord st i a -> Cord st i a
cordcat x = fastcat =<< collect x
+cordnewcat :: Cord st i a -> Cord st i a
+cordnewcat x = newcat =<< collect x
+
timerun :: Cord st i Time -> Cord st i Int
timerun tz = (fastcyclecatpat . flip zip (map pure [0 :: Int ..])) =<< collect tz
@@ -176,7 +179,7 @@
arp :: Cord st i a -> Cord st i a
arp x = apply (squeezeMap (pure . bump) ds) x
where
- d = C.depth x
+ d = C.length x
ds = enumFromThenToStack @Time 0 ((\dp -> if dp == 0 then 0 else 1 / fromIntegral dp) <$> d) 1
echoWith :: Cord st i Int -> Cord st i Time -> Cord st i (Cord st i a -> Cord st i a) -> Cord st i a -> Cord st i a
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Map.hs b/src/zwirn-core/Zwirn/Core/Lib/Map.hs
--- a/src/zwirn-core/Zwirn/Core/Lib/Map.hs
+++ b/src/zwirn-core/Zwirn/Core/Lib/Map.hs
@@ -44,6 +44,10 @@
union :: (Applicative m, Ord k) => ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)
union = liftA2 (flip Map.union)
+-- | union of two maps, if a key exists in both, the value will come from the left
+unionL :: (Applicative m, Ord k) => ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)
+unionL = liftA2 Map.union
+
-- | lookup a value via key
lookup :: (HasSilence m, MultiMonad m, Ord k) => ZwirnT m st i k -> ZwirnT m st i (Map k a) -> ZwirnT m st i a
lookup tz xz = outerJoin $ liftA2Right (\t x -> fromLookup $ Map.lookup t x) tz xz
@@ -130,3 +134,33 @@
where
modGain e (Just g) = Just $ g * e
modGain e Nothing = Just e
+
+-----------------------------------------------------------------
+------------------ Doux specific versions ----------------------
+-----------------------------------------------------------------
+
+loopAtDoux :: (Fractional a, HasSilence m, Monad m, Ord k, IsString k, State m st i) => ZwirnT m st i Time -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)
+loopAtDoux zt zx = (_loopAt <$> zt <*> cyclesPerSecond) `innerApply` zx
+ where
+ _loopAt 0 _ _ = silence
+ _loopAt t cps x = Map.insert "fit" (realToFrac t / realToFrac cps) <$> slow (pure t) x
+
+sliceDoux :: (Fractional a, MultiApplicative m, Ord k, IsString k) => ZwirnT m st i Int -> ZwirnT m st i Int -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)
+sliceDoux nz iz zm = _slice <$> nz *> iz <*> zm
+ where
+ _slice 0 _ m = m
+ _slice n i m = Map.unions [Map.singleton "begin" newb, Map.singleton "end" newe, fit]
+ where
+ b = fromMaybe 0 $ Map.lookup "begin" m
+ e = fromMaybe 1 $ Map.lookup "end" m
+ fit = Map.alter (fmap (\x -> x / fromIntegral n)) "fit" m
+ newrange x = e * x + (1 - x) * b
+ newb = newrange $ div' i n
+ newe = newrange $ div' i n + if n == 1 then 1 else div' 1 n
+ div' num den = fromIntegral (num `mod` den) / fromIntegral den
+
+chopDoux :: (Fractional a, MultiMonad m, HasSilence m, Ord k, IsString k) => ZwirnT m st i Int -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)
+chopDoux nz = squeezeMap (quicksliceDoux nz (run nz))
+
+quicksliceDoux :: (Fractional a, MultiMonad m, Ord k, IsString k) => ZwirnT m st i Int -> ZwirnT m st i Int -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)
+quicksliceDoux nz iz = squeezeMap (sliceDoux nz iz)
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs b/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs
--- a/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs
+++ b/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs
@@ -169,3 +169,15 @@
fastcyclecatpat :: (MultiMonad k, HasSilence k) => [(ZwirnT k st i Time, ZwirnT k st i a)] -> ZwirnT k st i a
fastcyclecatpat xs = cyclecatpat $ map (\(t, x) -> (t, slow t x)) xs
+
+newcat :: (HasSilence k) => [ZwirnT k st i a] -> ZwirnT k st i a
+newcat [] = silence
+newcat obj = zwirn q
+ where
+ q t = unzwirn item phase
+ where
+ metre = fromIntegral $ length obj
+ scaledPhase = t * metre
+ item = nth scaledPhase obj
+ cy = floor t
+ phase = fromIntegral @Int cy + mod' t (recip metre)
diff --git a/src/zwirn-core/Zwirn/Core/Lib/State.hs b/src/zwirn-core/Zwirn/Core/Lib/State.hs
--- a/src/zwirn-core/Zwirn/Core/Lib/State.hs
+++ b/src/zwirn-core/Zwirn/Core/Lib/State.hs
@@ -37,6 +37,12 @@
set :: (Monad k) => ZwirnT k st i st -> ZwirnT k st i a -> ZwirnT k st i a
set st a = (withState . const <$> st) `innerApply` a
+cycleToSecond :: (HasSilence m, MultiMonad m, State m st i) => ZwirnT m st i Double -> ZwirnT m st i Double
+cycleToSecond zs = innerJoin $ fmap (\x -> if x == 0 then silence else (/ x) <$> zs) cyclesPerSecond
+
+secondToCycle :: (MultiMonad m, State m st i) => ZwirnT m st i Double -> ZwirnT m st i Double
+secondToCycle = liftA2 (*) cyclesPerSecond
+
-- functions to act on state that is a map
-- | get value of specific key, providing a function in case key is not found
diff --git a/src/zwirn-core/Zwirn/Core/Query.hs b/src/zwirn-core/Zwirn/Core/Query.hs
--- a/src/zwirn-core/Zwirn/Core/Query.hs
+++ b/src/zwirn-core/Zwirn/Core/Query.hs
@@ -40,12 +40,12 @@
findAllValuesWithTimeState = findAllValuesWithTimeStatePrec 0.005
findAllValuesWithTimePrec :: (ToList k) => Time -> (Time, Time) -> st -> ZwirnT k st i a -> [(Time, a)]
-findAllValuesWithTimePrec prec (start, end) st z = map (\(t, v, _) -> (t, value v)) xs
+findAllValuesWithTimePrec prec (start, end) st z = map (\(Time t _, v, _) -> (Time t (tDiff $ time v), value v)) xs
where
(xs, _) = findAllBreakpoints prec start end st z
findAllValuesWithTimeStatePrec :: (ToList k) => Time -> (Time, Time) -> st -> ZwirnT k st i a -> ([(Time, a)], st)
-findAllValuesWithTimeStatePrec prec (start, end) st z = (map (\(t, v, _) -> (t, value v)) xs, st')
+findAllValuesWithTimeStatePrec prec (start, end) st z = (map (\(Time t _, v, _) -> (Time t (tDiff $ time v), value v)) xs, st')
where
(xs, st') = findAllBreakpoints prec start end st z
diff --git a/src/zwirn-core/Zwirn/Core/Types.hs b/src/zwirn-core/Zwirn/Core/Types.hs
--- a/src/zwirn-core/Zwirn/Core/Types.hs
+++ b/src/zwirn-core/Zwirn/Core/Types.hs
@@ -43,6 +43,7 @@
class State k st i where
beatsPerCycle :: ZwirnT k st i Double
+ cyclesPerSecond :: ZwirnT k st i Double
class ToList k where
toList :: k a -> [a]
diff --git a/src/zwirn-doux/Zwirn/Doux/Env.hs b/src/zwirn-doux/Zwirn/Doux/Env.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-doux/Zwirn/Doux/Env.hs
@@ -0,0 +1,89 @@
+module Zwirn.Doux.Env where
+
+import Control.Monad (void)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Sound.Doux.Engine (panic)
+import Zwirn.Doux.Types (Stream (..))
+import Zwirn.Doux.UI
+import Zwirn.Language.Builtin.Internal
+import Zwirn.Language.Builtin.Prelude (builtinEnvironmentWithPlayEnvDoux, instances)
+import Zwirn.Language.Environment
+import Zwirn.Language.Evaluate (Expression, ToExpression (..), Zwirn)
+import Zwirn.Language.Play
+
+builtinEnvironmentWithStream :: Stream -> InterpreterEnv
+builtinEnvironmentWithStream str = IEnv (Map.unions [std, streamFunctions str]) instances
+ where
+ (IEnv std _) = builtinEnvironmentWithPlayEnvDoux (playEnvFromStream str)
+
+playEnvFromStream :: Stream -> PlayEnv
+playEnvFromStream str = (PlayEnv {playMap = sPlayMap str, actionMap = sActionMap str, busMap = sBusMap str})
+
+once :: Stream -> Zwirn Expression -> Zwirn (IO ())
+once str iz = pure (streamNow str iz)
+
+panicStream :: Stream -> Zwirn (IO ())
+panicStream str = pure (void $ panic (sDoux str) >> playHush (PlayEnv (sPlayMap str) (sActionMap str) (sBusMap str)))
+
+bpm :: Stream -> Zwirn Double -> Zwirn (IO ())
+bpm str iz = streamSetBPM str . realToFrac <$> iz
+
+cps :: Stream -> Zwirn Double -> Zwirn (IO ())
+cps str iz = streamSetCPS str . realToFrac <$> iz
+
+setcycle :: Stream -> Zwirn Double -> Zwirn (IO ())
+setcycle str iz = streamSetCycle str . realToFrac <$> iz
+
+nudge :: Stream -> Zwirn Double -> Zwirn (IO ())
+nudge str iz = streamNudge str <$> iz
+
+resetcycles :: Stream -> Zwirn (IO ())
+resetcycles str = pure $ streamResetCycles str
+
+enablelink :: Stream -> Zwirn (IO ())
+enablelink str = pure $ streamEnableLink str
+
+disablelink :: Stream -> Zwirn (IO ())
+disablelink str = pure $ streamDisableLink str
+
+streamFunctions :: Stream -> Map.Map T.Text AnnotatedExpression
+streamFunctions str =
+ Map.unions
+ [ "once"
+ === toExp (once str)
+ <:: "Map -> Action"
+ --| "play one cycle of the given zwirn",
+ "bpm"
+ === toExp (bpm str)
+ <:: "Number -> Action"
+ --| "set the current bpm (beats per minute)",
+ "cps"
+ === toExp (cps str)
+ <:: "Number -> Action"
+ --| "set the current cps (cycles per second)",
+ "resetcycles"
+ === toExp (resetcycles str)
+ <:: "Action"
+ --| "resets the cycle count to 0",
+ "setcycle"
+ === toExp (setcycle str)
+ <:: "Number -> Action"
+ --| "set the current cycle to specific point in time",
+ "nudge"
+ === toExp (nudge str)
+ <:: "Number -> Action"
+ --| "set the current nudge of the stream",
+ "panic"
+ === toExp (panicStream str)
+ <:: "Action"
+ --| "stop all sound immediately",
+ "disablelink"
+ === toExp (disablelink str)
+ <:: "Action"
+ --| "disable ableton link",
+ "enablelink"
+ === toExp (enablelink str)
+ <:: "Action"
+ --| "enable ableton link"
+ ]
diff --git a/src/zwirn-doux/Zwirn/Doux/Process.hs b/src/zwirn-doux/Zwirn/Doux/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-doux/Zwirn/Doux/Process.hs
@@ -0,0 +1,193 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Zwirn.Doux.Process where
+
+import Control.Concurrent (MVar, forkIO, modifyMVar_, threadDelay)
+import Control.Concurrent.MVar (readMVar)
+import Control.Monad (void)
+import Data.Bifunctor (Bifunctor (..))
+import Data.List
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Data.Tuple (swap)
+import Data.Word (Word64)
+import Sound.Doux.Engine
+import Sound.Tidal.Clock
+import qualified Sound.Tidal.Clock as Clock
+import Sound.Tidal.Link (Micros, SessionState, clock)
+import Zwirn.Core.Query (findAllValuesWithTimePrec, findAllValuesWithTimeStatePrec)
+import qualified Zwirn.Core.Time as Z
+import Zwirn.Core.Types (ToList (..), Value (..), unzwirn)
+import Zwirn.Language.Evaluate (Expression (..), ExpressionMap, toExp)
+import Zwirn.Language.Evaluate.Expression (Zwirn)
+import Zwirn.Language.Play
+
+tickAction ::
+ Doux ->
+ MVar PlayMap ->
+ MVar ActionMap ->
+ MVar BusMap ->
+ MVar ExpressionMap ->
+ Time ->
+ (Time, Time) ->
+ Double ->
+ ClockConfig ->
+ ClockRef ->
+ (SessionState, SessionState) ->
+ IO ()
+tickAction d pMV acMV busMV stMV prec (star, end) nudge cconf cref (ss, _) = do
+ vs <- processPlayMap prec (star, end) pMV stMV
+ bs <- processBusMap prec (star, end) busMV stMV
+ as <- processActionMap prec (star, end) acMV stMV
+ mapM_ (tickAndSend d False nudge cconf cref ss) vs
+ mapM_ (tickAndSendBus d nudge cconf cref ss) bs
+ mapM_ (execAction nudge cconf cref ss) as
+ updateTempo cconf cref stMV
+
+processPlayMap :: Time -> (Time, Time) -> MVar PlayMap -> MVar ExpressionMap -> IO [(Z.Time, Expression)]
+processPlayMap prec (star, end) pMV stMV = do
+ pm <- readMVar pMV
+ let ps = resolvePlayMap pm
+ st <- readMVar stMV
+
+ let (enst, vs) = mapAccumL (\ !s (Targeted _ p) -> swap $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
+ modifyMVar_ stMV (const $ return enst)
+ return $ concat vs
+
+processBusMap :: Time -> (Time, Time) -> MVar BusMap -> MVar ExpressionMap -> IO [(Int, Z.Time, Expression)]
+processBusMap prec (star, end) busMV stMV = do
+ bm <- readMVar busMV
+ let bs = Map.toList bm
+ st <- readMVar stMV
+
+ return $ concatMap (\(i, Targeted _ p) -> map (\(x, y) -> (i, x, y)) $ findAllValuesWithTimePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) st p) bs
+
+processActionMap :: Time -> (Time, Time) -> MVar ActionMap -> MVar ExpressionMap -> IO [(Z.Time, IO ())]
+processActionMap prec (star, end) zMV stMV = do
+ pm <- readMVar zMV
+ let ps = Map.elems pm
+ st <- readMVar stMV
+
+ let (_, vs) = mapAccumL (\ !s p -> swap $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
+
+ return $ map (second expressionToAction) (concat vs)
+
+align :: Time -> Time -> Time
+align prec t = fromIntegral (floor $ t / prec :: Int) * prec
+
+expressionToPath :: Expression -> IO String
+expressionToPath (ENum x) = return $ show x
+expressionToPath (EText x) = return $ T.unpack x
+expressionToPath (EMap x) = do
+ xs <- mapM (\(k, v) -> (\y -> T.unpack k ++ "/" ++ y) <$> expressionToPath v) $ Map.toList x
+ return $ intercalate "/" xs
+expressionToPath (EAction x) = forkIO x >> return ""
+expressionToPath _ = return ""
+
+expressionToAction :: Expression -> IO ()
+expressionToAction (EAction x) = x
+expressionToAction _ = return ()
+
+expressionToPathSound :: Expression -> Double -> IO (Maybe (String, String))
+expressionToPathSound (EMap m) gate = case Map.lookup "s" gm of
+ Just s -> do
+ samp <- expressionToPath s
+ rest <- expressionToPath (EMap $ Map.delete "s" gm)
+ return $ Just ("sound/" ++ samp, rest)
+ Nothing -> return Nothing
+ where
+ gm =
+ Map.alter altGate "gate"
+ . Map.alter altOrbitFx "feedback"
+ . Map.alter altOrbitFx "verb"
+ . Map.alter altOrbitFx "delay"
+ . Map.alter altOrbitFx "comb"
+ $ m
+ altGate (Just x) = Just x
+ altGate Nothing = Just (ENum gate)
+ altOrbitFx (Just x) = Just x
+ altOrbitFx Nothing = Just (ENum 0)
+expressionToPathSound (EAction x) _ = forkIO x >> return Nothing
+expressionToPathSound _ _ = return Nothing
+
+tickAndSend :: Doux -> Bool -> Double -> ClockConfig -> ClockRef -> SessionState -> (Z.Time, Expression) -> IO ()
+tickAndSend d immediate nudge cconf cref ss (Z.Time r s, ex) = do
+ let onBeat = Clock.cyclesToBeat cconf (fromRational r)
+
+ on <- Clock.timeAtBeat cconf ss onBeat
+ tic <- scheduleAtLink d cref nudge on
+ cps <- getCPS cconf cref
+
+ let gate = fromRational $ 1 / (cps * s) :: Double
+
+ mpath <- expressionToPathSound ex gate
+
+ case mpath of
+ Just (sound, path) -> if immediate then void (eval d (sound ++ "/" ++ path)) else void (eval d (sound ++ "/tick/" ++ show tic ++ "/" ++ path))
+ Nothing -> return ()
+
+tickAndSendBus :: Doux -> Double -> ClockConfig -> ClockRef -> SessionState -> (Int, Z.Time, Expression) -> IO ()
+tickAndSendBus d nudge cconf cref ss (bus, t, ex) = do
+ let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)
+
+ on <- Clock.timeAtBeat cconf ss onBeat
+ tic <- scheduleAtLink d cref nudge on
+
+ path <- expressionToPath ex
+
+ void (eval d ("tick/" ++ show tic ++ "/" ++ path ++ "/voice/" ++ show bus))
+
+-- | execAction runs actions in the action map. this is quite inefficient, since for every action a separate green thread is spawned
+-- | eventually we should probably have a separate thread for running actions that reacts to a queue
+execAction :: Double -> ClockConfig -> ClockRef -> SessionState -> (Z.Time, IO ()) -> IO ()
+execAction nudge cconf cref ss (t, action) = do
+ let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)
+ on <- Clock.timeAtBeat cconf ss onBeat
+ nowLink <- clock (rAbletonLink cref)
+ let delay = max 0 (on - nowLink - round (nudge * 1000))
+ void $ forkIO $ do
+ threadDelay (fromIntegral delay)
+ action
+
+updateTempo :: ClockConfig -> ClockRef -> MVar ExpressionMap -> IO ()
+updateTempo cconf cref stMV = do
+ bpm <- realToFrac <$> Clock.getBPM cref
+ cps <- realToFrac <$> Clock.getCPS cconf cref
+ modifyMVar_ stMV (return . Map.insert "_cps" (toExp (pure cps :: Zwirn Double)) . Map.insert "_tempo" (toExp (pure bpm :: Zwirn Double)))
+
+tickActionOnce ::
+ Doux ->
+ MVar PlayMap ->
+ MVar ExpressionMap ->
+ Time ->
+ (Time, Time) ->
+ Double ->
+ ClockConfig ->
+ ClockRef ->
+ (SessionState, SessionState) ->
+ IO ()
+tickActionOnce d pMV stMV _ (star, _) nudge cconf cref (ss, _) = do
+ vs <- processPlayMapOnce star pMV stMV
+ mapM_ (tickAndSend d True nudge cconf cref ss) vs
+
+scheduleAtLink :: Doux -> ClockRef -> Double -> Micros -> IO Word64
+scheduleAtLink doux cref nudge targetLinkTime = do
+ liveTick <- currentTick doux
+ nowLink <- clock (rAbletonLink cref)
+ sr <- sampleRate doux
+ let deltaMicros = targetLinkTime - nowLink
+ deltaTicks = round (fromIntegral deltaMicros * realToFrac sr / 1000000 :: Double)
+ nudgeTicks = round (nudge * 1000 * realToFrac sr / 1000000) :: Word64
+ actual = if liveTick + deltaTicks > nudgeTicks then liveTick + deltaTicks - nudgeTicks else liveTick + deltaTicks
+ return actual
+
+processPlayMapOnce :: Time -> MVar PlayMap -> MVar ExpressionMap -> IO [(Z.Time, Expression)]
+processPlayMapOnce star pMV stMV = do
+ pm <- readMVar pMV
+ let ps = resolvePlayMap pm
+ st <- readMVar stMV
+
+ let func !s (Targeted _ p) = (s, map (\(v, _) -> (Z.Time star (Z.tDiff $ time v), value v)) $ toList $ unzwirn p (Z.Time star 1) s)
+ (enst, vs) = mapAccumL func st ps
+ modifyMVar_ stMV (const $ return enst)
+ return $ concat vs
diff --git a/src/zwirn-doux/Zwirn/Doux/Types.hs b/src/zwirn-doux/Zwirn/Doux/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-doux/Zwirn/Doux/Types.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Zwirn.Doux.Types where
+
+import Control.Concurrent.MVar
+import GHC.Generics (Generic)
+import Sound.Doux.Engine
+import Sound.Tidal.Clock
+import Zwirn.Language.Evaluate (ExpressionMap)
+import Zwirn.Language.Play
+
+data StreamConfig = StreamConfig
+ { streamConfigPrecision :: Rational,
+ streamConfigSamples :: Maybe FilePath,
+ streamConfigInput :: Maybe String,
+ streamConfigOutput :: Maybe String,
+ streamConfigHost :: Maybe String,
+ streamConfigBufferSize :: Int,
+ streamConfigChannels :: Int,
+ streamConfigBlockSize :: Int,
+ streamConfigMaxVoices :: Int,
+ streamConfigClock :: ClockConfig
+ }
+ deriving (Generic)
+
+data Stream = Stream
+ { sDoux :: Doux,
+ sPlayMap :: MVar PlayMap,
+ sActionMap :: MVar ActionMap,
+ sBusMap :: MVar BusMap,
+ sState :: MVar ExpressionMap,
+ sClockRef :: ClockRef,
+ sConfig :: StreamConfig
+ }
+
+defaultDouxClockConfig :: ClockConfig
+defaultDouxClockConfig =
+ ClockConfig
+ { clockFrameTimespan = 1 / 20,
+ clockEnableLink = False,
+ clockProcessAhead = 1 / 10,
+ clockSkipTicks = 10,
+ clockQuantum = 4,
+ clockBeatsPerCycle = 4
+ }
diff --git a/src/zwirn-doux/Zwirn/Doux/UI.hs b/src/zwirn-doux/Zwirn/Doux/UI.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-doux/Zwirn/Doux/UI.hs
@@ -0,0 +1,79 @@
+module Zwirn.Doux.UI where
+
+import Control.Concurrent.MVar
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import Sound.Doux.Engine
+import Sound.Tidal.Clock
+import qualified Sound.Tidal.Clock as Clock
+import Zwirn.Core.Lib.Modulate (shift)
+import Zwirn.Doux.Process
+import Zwirn.Doux.Types (Stream (..), StreamConfig (..))
+import Zwirn.Language.Evaluate (Expression, Zwirn)
+import Zwirn.Language.Play
+
+startStream :: StreamConfig -> IO Stream
+startStream config = do
+ let conf = (streamConfigClock config) {clockFrameTimespan = 10 * realToFrac (streamConfigPrecision config)}
+ d <- create (Config (streamConfigSamples config) (streamConfigInput config) (streamConfigOutput config) (streamConfigHost config) (streamConfigBufferSize config) (streamConfigChannels config) (streamConfigBlockSize config) (streamConfigMaxVoices config))
+
+ zMV <- newMVar Map.empty
+ stMV <- newMVar Map.empty
+ busMapMV <- newMVar Map.empty
+ actionMapMV <- newMVar Map.empty
+
+ cref <- clocked conf (tickAction d zMV actionMapMV busMapMV stMV (streamConfigPrecision config))
+ let str = Stream d zMV actionMapMV busMapMV stMV cref config
+ streamSetBPM str (realToFrac streamDefaultBPM)
+ return str
+
+streamDefaultBPM :: Double
+streamDefaultBPM = 138
+
+streamSet :: Stream -> T.Text -> Expression -> IO ()
+streamSet str x ex = modifyMVar_ (sState str) (return . Map.insert x ex)
+
+streamSetCPS :: Stream -> Time -> IO ()
+streamSetCPS str c = streamSetBPM str (c * toRational (clockBeatsPerCycle (streamConfigClock $ sConfig str) * 60))
+
+-- | set the bpm in the clock
+streamSetBPM :: Stream -> Time -> IO ()
+streamSetBPM s = Clock.setBPM (sClockRef s)
+
+streamGetBPM :: Stream -> IO Double
+streamGetBPM str = realToFrac <$> Clock.getBPM (sClockRef str)
+
+streamGetCPS :: Stream -> IO Double
+streamGetCPS str = realToFrac <$> Clock.getCPS (streamConfigClock $ sConfig str) (sClockRef str)
+
+streamResetCycles :: Stream -> IO ()
+streamResetCycles s = streamSetCycle s 0
+
+streamSetCycle :: Stream -> Time -> IO ()
+streamSetCycle s = Clock.setClock (sClockRef s)
+
+streamGetCycle :: Stream -> IO Int
+streamGetCycle s = floor <$> streamGetNow s
+
+streamEnableLink :: Stream -> IO ()
+streamEnableLink s = Clock.enableLink (sClockRef s)
+
+streamDisableLink :: Stream -> IO ()
+streamDisableLink s = Clock.disableLink (sClockRef s)
+
+streamGetNow :: Stream -> IO Time
+streamGetNow s = Clock.getCycleTime (streamConfigClock $ sConfig s) (sClockRef s)
+
+streamNudge :: Stream -> Double -> IO ()
+streamNudge s = Clock.setNudge (sClockRef s)
+
+streamFirst :: Stream -> Zwirn Expression -> IO ()
+streamFirst str z = do
+ dummy <- newMVar $ Map.singleton (TextID $ T.pack "_streamOnceDummy_") (Targeted [] (Normal, z, Nothing))
+ Clock.clockOnce (tickActionOnce (sDoux str) dummy (sState str) (streamConfigPrecision $ sConfig str)) (streamConfigClock $ sConfig str) (sClockRef str)
+
+streamNow :: Stream -> Zwirn Expression -> IO ()
+streamNow str z = do
+ now <- streamGetNow str
+ dummy <- newMVar $ Map.singleton (TextID $ T.pack "_streamOnceDummy_") (Targeted [] (Normal, shift (realToFrac $ -now) z, Nothing))
+ Clock.clockOnce (tickActionOnce (sDoux str) dummy (sState str) (streamConfigPrecision $ sConfig str)) (streamConfigClock $ sConfig str) (sClockRef str)
diff --git a/src/zwirn-lang/Zwirn/Language/Builtin/DouxParameters.hs b/src/zwirn-lang/Zwirn/Language/Builtin/DouxParameters.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Builtin/DouxParameters.hs
@@ -0,0 +1,193 @@
+module Zwirn.Language.Builtin.DouxParameters where
+
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import Zwirn.Core.Lib.Map
+import Zwirn.Core.Lib.State (cycleToSecond)
+import Zwirn.Language.Builtin.Internal
+import qualified Zwirn.Language.Builtin.Parameters as P
+import Zwirn.Language.Environment
+import Zwirn.Language.Evaluate (Expression, ExpressionMap, Zwirn, toExp)
+import Zwirn.Language.Evaluate.Expression (Expression (..))
+
+builtinParams :: Map.Map Text AnnotatedExpression
+builtinParams = Map.unions [builtinTextParams, builtinNumberParams, builtinSecondParams, builtinSources, orbitGlobalFX, noteExpressions, chordExpressions]
+
+noteExpressions :: Map.Map Text AnnotatedExpression
+noteExpressions = Map.unions $ map (\n -> noDesc $ n === toExp ((pure $ P.toNote n + 60) :: Zwirn Int) <:: "Number") P.notes
+
+chordExpressions :: Map.Map Text AnnotatedExpression
+chordExpressions = P.chordExpressions
+
+builtinTextParams :: Map.Map Text AnnotatedExpression
+builtinTextParams = Map.unions $ map (\(name, range, d) -> name === toExp ((fmap toExp . singleton (pure name)) :: Zwirn Expression -> Zwirn Expression) <:: "Text -> Map" --| ((if T.null range then "" else "range: " <> range) <> if T.null d then "" else "\ndefault: " <> d)) textParams
+
+builtinSources :: Map.Map Text AnnotatedExpression
+builtinSources = Map.unions $ exceptions : map (\name -> noDesc $ name === EZwirn (pure (EMap $ Map.singleton "s" (EText name))) <:: "Map") sources
+
+builtinNumberParams :: Map.Map Text AnnotatedExpression
+builtinNumberParams = Map.unions $ map (\(name, range, d) -> name === toExp ((fmap toExp . singleton (pure name)) :: Zwirn Double -> Zwirn Expression) <:: "Number -> Map" --| ((if T.null range then "" else "range: " <> range) <> if T.null d then "" else "\ndefault: " <> d)) numberParams
+
+builtinSecondParams :: Map.Map Text AnnotatedExpression
+builtinSecondParams = Map.unions $ map (\(name, range, d) -> name === toExp ((fmap toExp . singleton (pure name) . cycleToSecond) :: Zwirn Double -> Zwirn Expression) <:: "Number -> Map" --| ((if T.null range then "" else "range: " <> range) <> if T.null d then "" else "\ndefault: " <> d)) secondParams
+
+exceptions :: Map.Map Text AnnotatedExpression
+exceptions =
+ Map.unions
+ [ noDesc $ "sinus" === EZwirn (pure (EMap $ Map.singleton "s" (EText "sine"))) <:: "Map",
+ noDesc $ "triangle" === EZwirn (pure (EMap $ Map.singleton "s" (EText "tri"))) <:: "Map",
+ noDesc $ "sawtooth" === EZwirn (pure (EMap $ Map.singleton "s" (EText "saw"))) <:: "Map"
+ ]
+
+sources :: [Text]
+sources =
+ ["zaw", "pulse", "pulze", "white", "pink", "brown", "vosc", "pluck"]
+ ++ ["kick", "snare", "hat", "tom", "rim", "cowbell", "cymbal", "plate", "clap"]
+ ++ ["plmodal", "plva", "plws", "plfm", "plgrain", "pladd", "plwt", "plchord", "plswarm", "plnoise"]
+ ++ ["live"]
+ ++ ["vox"]
+
+textParams :: [(Text, Text, Text)]
+textParams =
+ [ ("s", "source", ""),
+ ("sound", "source", ""),
+ ("bank", "", ""),
+ ("subwave", "tri | sine | square", ""),
+ ("syncmode", "hard | soft", ""),
+ ("vibshape", "sine | tri | saw | square | sh", "sine"),
+ ("fmshape", "sine | tri | saw | square | sh", "sine"),
+ ("amshape", "sine | tri | saw | square | sh", "sine"),
+ ("rmshape", "sine | tri | saw | square | sh", "sine"),
+ ("flangermode", "classic | throughzero", "classic"),
+ ("chorusmode", "classic | ensemble | dimension", "classic"),
+ ("delaytype", "standard | pingpong | tape | multitap", "standard"),
+ ("verbtype", "space | plate", "space"),
+ ("foldmode", "triangle | sine | wrap", "triangle"),
+ ("distortmode", "soft | tanh | arctan | hardclip | parabolic | sinarctan", "soft"),
+ ("vinyltype", "dull | clear | cassette", "dull")
+ ]
+
+numberParams :: [(Text, Text, Text)]
+numberParams =
+ [("shape", "0-1", "0.5"), ("punch", "0-1", "0.5"), ("grit", "0-1", "0.5"), ("drumkit", "0-7", "0")]
+ ++ [("inchan", ">=0", "0")]
+ ++ [("scan", "0-1", "0"), ("wtlen", ">=0", "0")]
+ ++ [("tense", "0-1", "0.6"), ("tonguex", "0-1", "0.06"), ("tonguey", "0-1", "0.69"), ("velum", "0-1", "0")]
+ ++ [("freq", "20-20000Hz", "330"), ("note", "0-127midi", ""), ("speed", "", "1"), ("detune", "cents", "0"), ("glide", ">=0", "0")]
+ ++ [("body", "0-1", "0"), ("sustain", "0-1", "1")]
+ ++ [("attackcurve", "-8-8", "-2"), ("decaycurve", "-8-8", "-2"), ("releasecurve", "-8-8", "-2")]
+ ++ [("orbit", "0-7", "0"), ("voice", ">=0", ""), ("reset", "0 | 1", "0")] -- chord?
+ ++ [("pw", "0-1", "0.5"), ("spread", "0-100", "0"), ("uni", "1-7", "2")]
+ ++ [("size", "0-256", "0"), ("warp", "-1-1", "0"), ("mirror", "0-1", "0")]
+ ++ [("sub", "0-1", "0"), ("suboct", "1-3", "1")]
+ ++ [("sync", "1-64", "1"), ("syncphase", "0-1", "0")]
+ ++ [("gain", ">=0", "1"), ("drive", "0-1", "0.12"), ("postgain", ">=0", "1"), ("velocity", "0-1", "1"), ("pan", "0-1", "0.5"), ("width", "0-2", "1"), ("haas", "0-35ms", "0")]
+ ++ [("vib", ">=0Hz", "0"), ("vibmod", ">=0semitones", "0")]
+ ++ [("drift", "0-100cents", "2")]
+ ++ [("fm", ">=0", "0"), ("fmh", ">=0", "1"), ("fm2", ">=0", "0"), ("fm2h", ">=0", "1"), ("fmpivot", "0-1", "0"), ("fmfb", ">=0", "0"), ("fmloop", "0-1", "0")]
+ ++ [("am", ">=0Hz", "0"), ("amdepth", "0-1", "0.5")]
+ ++ [("rm", ">=0Hz", "0"), ("rmdepth", "0-1", "1")]
+ ++ [("n", ">=0", "0"), ("begin", "0-1", "0"), ("end", "0-1", "1"), ("cut", ">=0", ""), ("stretch", ">=0", "1"), ("grain", "0-1000", "0"), ("spray", "0-1", "0"), ("dens", "1-8", "2")]
+ -- recroder ?
+ -- multichan ?
+ -- busses ?
+ ++ [("lpf", "20-20000Hz", ""), ("lpq", "0-1", "0.2"), ("kf", "0-1", "0")]
+ ++ [("hpf", "20-20000Hz", ""), ("hpq", "0-1", "0.2")]
+ ++ [("bpf", "20-20000Hz", ""), ("bpq", "0-1", "0.2")]
+ ++ [("combfreq", "20-20000Hz", "220"), ("combfeedback", "0-0.99", "0.9"), ("combdamp", "0-1", "0.1")]
+ ++ [("llpf", "20-20000Hz", ""), ("llpq", "0-1", "0.2"), ("lhpf", "20-20000Hz", ""), ("lhpq", "0-1", "0.2"), ("lbpf", "20-20000Hz", ""), ("lbpq", "0-1", "0.2")]
+ ++ [("slpf", "20-20000Hz", ""), ("slpq", "0-1", "0.2")]
+ ++ [("shpf", "20-20000Hz", ""), ("shpq", "0-1", "0.2")]
+ ++ [("sbpf", "20-20000Hz", ""), ("sbpq", "0-1", "0.2")]
+ ++ [("modal", "0-1", "0"), ("modalfreq", "20-20000Hz", "220"), ("modaldecay", "0.05-20s", "2"), ("modalstruct", "0-1", "0"), ("modalbright", "0-1", "0.5")]
+ ++ [("phaser", ">=0", "0"), ("phaserdepth", "0-1", "0.5"), ("phasersweep", ">=0Hz", "2000"), ("phasercenter", "20-20000Hz", "1000")]
+ ++ [("flanger", ">=0Hz", "0"), ("flangerdepth", "0-1", "0.5"), ("flangerfeedback", "0-0.95", "0")]
+ ++ [("fshift", "-2000-2000Hz", "0")]
+ ++ [("pshift", "-24-24semitones", "0"), ("pshiftwin", "5-200ms", "40")]
+ ++ [("chorus", ">=0Hz", "0"), ("chorusdepth", "0-1", "0.5"), ("chorusdelay", ">=0ms", "20")]
+ ++ [("fbtime", "0.1-680ms", "10"), ("fbdamp", "0-1", "0"), ("fbcross", "0-1", "0")]
+ ++ [("delayfeedback", "0-1", "0.5")]
+ ++ [("verbdecay", "0-1", "0.75"), ("verbdamp", "0-1", "0.95"), ("verbpredelay", "0-1", "0"), ("verbdiff", "0-1", "0.7"), ("verbchorus", "0-1", "0.3"), ("verbchorusfreq", "0-1", "0.2"), ("verbprelow", "0-1", "0.2"), ("verbprehigh", "0-1", "0.8"), ("verblowcut", "0-1", "0.5"), ("verbhighcut", "0-1", "0.7"), ("verblowgain", "0-1", "0.4")]
+ ++ [("coarse", ">=1", "1"), ("crush", "1-16bits", "16"), ("fold", "0-1", "0"), ("wrap", ">=1", "1"), ("distort", ">=0", "1"), ("distortvol", ">=0", "1"), ("distortasym", "-1-1", "0")]
+ ++ [("eqlo", "dB", "0"), ("eqmid", "dB", "0"), ("eqhi", "dB", "0")]
+ ++ [("eqlofreq", "Hz", "200"), ("eqmidfreq", "Hz", "1000"), ("eqhifreq", "Hz", "5000"), ("eqmidq", "0.2-8", "0.7")]
+ ++ [("tilt", "-1-1", "0")]
+ ++ [("smear", "0-1", "0"), ("smearfreq", ">=20Hz", "1000"), ("smearfb", "0-0.95", "0")]
+ ++ [("wah", "0-1", "0"), ("wahpeak", "0-1", "0.5"), ("wahsens", "0-1", "0.5"), ("wahmanual", "100-4000Hz", "400")]
+ ++ [("vowel", "0-4", "0"), ("vowtype", "0-4", "1")]
+ ++ [("vinyl", "0-1", "0"), ("vinylwow", "0-1", "0.3"), ("vinylnoise", "0-1", "0.2"), ("vinyltone", "-1-1", "0")]
+ ++ [("comp", "0-1", "0"), ("comprelease", "0.001-2s", "0.15"), ("comporbit", "0-7", "0")]
+
+secondParams :: [(Text, Text, Text)]
+secondParams =
+ [("gate", ">=0cycles", "1")] -- time?
+ ++ [("envdelay", ">=0s", "0"), ("attack", ">=0s", "0.003"), ("hold", ">=0s", "0"), ("decay", ">=0s", "0"), ("release", ">=0s", "0.005")]
+ ++ [("delaytime", ">=0", "0.25")]
+ ++ [("compattack", "0.001-1s", "0.01")]
+
+orbitGlobalFX :: Map.Map Text AnnotatedExpression
+orbitGlobalFX =
+ Map.unions
+ [ "verb" === toExp verb <:: "Number -> Map" --| "range: 0-1\ndefault: 0",
+ "feedback" === toExp feedback <:: "Number -> Map" --| "range: 0-1\ndefault: 0",
+ "delay" === toExp delay <:: "Number -> Map" --| "range: 0-1\ndefault: 0",
+ "comb" === toExp comb <:: "Number -> Map" --| "range: 0-1\ndefault: 0"
+ ]
+ where
+ verb :: Zwirn Double -> Zwirn ExpressionMap
+ verb =
+ fmap
+ ( \d ->
+ Map.fromList
+ [ ("verb", ENum d),
+ ("verbdecay", 0.75),
+ ("verbdamp", 0.95),
+ ("verbpredelay", 0),
+ ("verbdiff", 0.7),
+ ("verbchorus", 0.3),
+ ("verbchorusfreq", 0.2),
+ ("verbprelow", 0.2),
+ ("verbprehigh", 0.8),
+ ("verblowcut", 0.5),
+ ("verbhighcut", 0.7),
+ ("verblowgain", 0.4),
+ ("verbtype", "space")
+ ]
+ )
+ delay :: Zwirn Double -> Zwirn ExpressionMap
+ delay dz =
+ liftA2
+ ( \d t ->
+ Map.fromList
+ [ ("delay", ENum d),
+ ("delayfeedback", 0.5),
+ ("delaytime", ENum t),
+ ("delaytype", "standard")
+ ]
+ )
+ dz
+ (cycleToSecond 0.25)
+
+ feedback :: Zwirn Double -> Zwirn ExpressionMap
+ feedback =
+ fmap
+ ( \d ->
+ Map.fromList
+ [ ("feedback", ENum d),
+ ("fbtime", 10),
+ ("fbdamp", 0),
+ ("fbcross", 0)
+ ]
+ )
+ comb :: Zwirn Double -> Zwirn ExpressionMap
+ comb =
+ fmap
+ ( \d ->
+ Map.fromList
+ [ ("comb", ENum d),
+ ("combfreq", 220),
+ ("combfeedback", 0.9),
+ ("combdamp", 0.1)
+ ]
+ )
diff --git a/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs b/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs
--- a/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs
+++ b/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs
@@ -12,7 +12,7 @@
import Zwirn.Language.Evaluate (Expression, Zwirn, toExp)
builtinParams :: Map.Map Text AnnotatedExpression
-builtinParams = addAliases aliases $ Map.unions [builtinTextParams, builtinNumberParams, builtinIntParams]
+builtinParams = Map.unions [addAliases aliases $ Map.unions [builtinTextParams, builtinNumberParams, builtinIntParams], noteExpressions, chordExpressions]
builtinTextParams :: Map.Map Text AnnotatedExpression
builtinTextParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Expression -> Zwirn Expression) <:: "Text -> Map") textParams
diff --git a/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs b/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs
--- a/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs
+++ b/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs
@@ -30,21 +30,26 @@
import Zwirn.Core.Lib.Modulate
import Zwirn.Core.Lib.Number as N
import Zwirn.Core.Lib.Random
+import Zwirn.Core.Lib.State (cycleToSecond, secondToCycle)
import Zwirn.Core.Lib.Structure as S
import Zwirn.Core.Time
+import qualified Zwirn.Language.Builtin.DouxParameters as Doux
import Zwirn.Language.Builtin.Internal
-import Zwirn.Language.Builtin.Parameters
+import qualified Zwirn.Language.Builtin.Parameters as P
import Zwirn.Language.Environment
import Zwirn.Language.Evaluate hiding (insert)
+import Zwirn.Language.Play (PlayEnv)
import Zwirn.Language.TypeCheck.Types
-import Zwirn.Stream.Types (Stream)
builtinEnvironment :: InterpreterEnv
-builtinEnvironment = IEnv builtins instances
+builtinEnvironment = IEnv builtinsSuperDirt instances
-builtinEnvironmentWithStream :: Stream -> InterpreterEnv
-builtinEnvironmentWithStream str = IEnv (Map.unions [builtins, streamFunctions str]) instances
+builtinEnvironmentWithPlayEnv :: PlayEnv -> InterpreterEnv
+builtinEnvironmentWithPlayEnv penv = IEnv (Map.unions [builtinsSuperDirt, playFunctionsSuperDirt penv]) instances
+builtinEnvironmentWithPlayEnvDoux :: PlayEnv -> InterpreterEnv
+builtinEnvironmentWithPlayEnvDoux penv = IEnv (Map.unions [builtinsDoux, playFunctionsDoux penv]) instances
+
instances :: [Instance]
instances =
[ IsIn "Num" numberT,
@@ -57,11 +62,14 @@
IsIn "Id" mapT
]
-builtinNames :: [Text]
-builtinNames = Map.keys builtins
+builtinNamesSuperDirt :: [Text]
+builtinNamesSuperDirt = Map.keys builtinsSuperDirt
-builtins :: Map.Map Text AnnotatedExpression
-builtins =
+builtinNamesDoux :: [Text]
+builtinNamesDoux = Map.keys builtinsDoux
+
+builtinsSuperDirt :: Map.Map Text AnnotatedExpression
+builtinsSuperDirt =
Map.unions
[ coreFunctions,
numberFunctions,
@@ -72,11 +80,26 @@
conditionalFunctions,
cordFunctions,
mapFunctions,
- builtinParams,
- noteExpressions,
- chordExpressions
+ sliceFunctionsSuperDirt,
+ P.builtinParams
]
+builtinsDoux :: Map.Map Text AnnotatedExpression
+builtinsDoux =
+ Map.unions
+ [ coreFunctions,
+ numberFunctions,
+ signals,
+ randomFunctions,
+ timeFunctions,
+ structureFunctions,
+ conditionalFunctions,
+ cordFunctions,
+ mapFunctions,
+ sliceFunctionsDoux,
+ Doux.builtinParams
+ ]
+
coreFunctions :: Map.Map Text AnnotatedExpression
coreFunctions =
Map.unions
@@ -151,7 +174,31 @@
"recvT"
=== toExp recvT
<:: "Text -> Number -> Map"
- --| "like recv but takes the parameter name as text"
+ --| "like recv but takes the parameter name as text",
+ "all"
+ === toExp allID
+ <:: "Text"
+ --| "special identifier to apply effects to all channels",
+ "none"
+ === toExp noneID
+ <:: "Text"
+ --| "special identifier to remove effects from all channels",
+ "bpc"
+ === toExp bpc
+ <:: "Number"
+ --| "current beats per cycle",
+ "tempo"
+ === toExp tempo
+ <:: "Number"
+ --| "current tempo in bpm",
+ "s2c"
+ === toExp (secondToCycle :: Zwirn Double -> Zwirn Double)
+ <:: "Number -> Number"
+ --| "convert seconds to cycles",
+ "c2s"
+ === toExp (cycleToSecond :: Zwirn Double -> Zwirn Double)
+ <:: "Number -> Number"
+ --| "convert cycles to seconds"
]
numberFunctions :: Map.Map Text AnnotatedExpression
@@ -787,6 +834,10 @@
=== toExp (cordcat :: Zwirn Expression -> Zwirn Expression)
<:: "a -> a"
--| "```cat [x, y, .. z] == [x y .. z]```",
+ "newcat"
+ === toExp (cordnewcat :: Zwirn Expression -> Zwirn Expression)
+ <:: "a -> a"
+ --| "",
"timerun"
=== toExp (timerun :: Zwirn Time -> Zwirn Int)
<:: "Number -> Number"
@@ -807,7 +858,7 @@
=== toExp (followWith :: Zwirn Int -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)
<:: "Number -> Number -> (a -> b) -> a -> b"
--| "",
- "fold"
+ "foldl"
=== toExp (fold :: Zwirn (Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn Expression -> Zwirn Expression)
<:: "(a -> a -> a) -> a -> a"
--| "fold a function over a cord",
@@ -815,10 +866,10 @@
=== toExp (interpol :: Zwirn Time -> Zwirn Time)
<:: "Number -> Number"
--| "linear interpolation of items in a cord",
- "depth"
- === toExp (depth :: Zwirn Expression -> Zwirn Int)
+ "length"
+ === toExp (C.length :: Zwirn Expression -> Zwirn Int)
<:: "a -> Number"
- --| "the depth of a cord",
+ --| "the top length of a cord",
"at"
=== toExp (at :: Zwirn Int -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)
<:: "Number -> (a -> a) -> a -> a"
@@ -833,6 +884,48 @@
--| "```cordFromThenTo x y z == [x, y .. z]```"
]
+sliceFunctionsSuperDirt :: Map.Map Text AnnotatedExpression
+sliceFunctionsSuperDirt =
+ Map.unions
+ [ "chop"
+ === toExp (chop :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Map -> Map"
+ --| "",
+ "striate"
+ === toExp (striate :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Map -> Map"
+ --| "",
+ "striateBy"
+ === toExp (striateBy :: Zwirn Int -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Number -> Map -> Map"
+ --| "",
+ "loopAt"
+ === toExp (loopAt :: Zwirn Time -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Map -> Map"
+ --| "",
+ "slice"
+ === toExp (slice :: Zwirn Int -> Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Number -> Map -> Map"
+ --| "slice a sample into equal btis and index into them"
+ ]
+
+sliceFunctionsDoux :: Map.Map Text AnnotatedExpression
+sliceFunctionsDoux =
+ Map.unions
+ [ "chop"
+ === toExp (chopDoux :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Map -> Map"
+ --| "",
+ "loopAt"
+ === toExp (loopAtDoux :: Zwirn Time -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Map -> Map"
+ --| "",
+ "slice"
+ === toExp (sliceDoux :: Zwirn Int -> Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
+ <:: "Number -> Number -> Map -> Map"
+ --| "slice a sample into equal btis and index into them"
+ ]
+
mapFunctions :: Map.Map Text AnnotatedExpression
mapFunctions =
Map.unions
@@ -864,14 +957,6 @@
=== toExp (M.fix :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
<:: "Text -> (a -> a) -> Map -> Map"
--| "apply a function to a specific key",
- "loopAt"
- === toExp (loopAt :: Zwirn Time -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
- <:: "Number -> Map -> Map"
- --| "",
- "slice"
- === toExp (slice :: Zwirn Int -> Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
- <:: "Number -> Number -> Map -> Map"
- --| "slice a sample into equal btis and index into them",
"juxBy"
=== toExp (juxBy :: Zwirn Expression -> Zwirn (Zwirn ExpressionMap -> Zwirn ExpressionMap) -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
<:: "Number -> (Map -> Map) -> Map -> Map"
@@ -884,29 +969,17 @@
=== toExp (echo :: Zwirn Int -> Zwirn Time -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
<:: "Number -> Number -> Number -> Map -> Map"
--| "",
- "chop"
- === toExp (chop :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
- <:: "Number -> Map -> Map"
- --| "",
- "striate"
- === toExp (striate :: Zwirn Int -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
- <:: "Number -> Map -> Map"
- --| "",
- "striateBy"
- === toExp (striateBy :: Zwirn Int -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn ExpressionMap)
- <:: "Number -> Number -> Map -> Map"
- --| "",
"param"
=== toExp paramName
<:: "(a -> Map) -> Text"
--| "given a parameter function, gives back the name of the parameter as text"
]
-streamFunctions :: Stream -> Map.Map Text AnnotatedExpression
-streamFunctions str =
+playFunctionsSuperDirt :: PlayEnv -> Map.Map Text AnnotatedExpression
+playFunctionsSuperDirt penv =
Map.unions
[ "replace"
- === toExp (replace str)
+ === toExp (replace penv)
<:: "Id a => a -> Map -> Action"
--| "replace the channel running with given id",
"target"
@@ -914,119 +987,124 @@
<:: "Id a => Text -> a -> Map"
--| "specify a specific target",
"($:)"
- === toExp (replace str)
+ === toExp (replace penv)
<:: "Id a => a -> Map -> Action"
--| "replace the channel running with given id",
"replaceAction"
- === toExp (replaceAction str)
+ === toExp (replaceAction penv)
<:: "Id a => a -> Action -> Action"
--| "replace the channel running with given id",
"($!)"
- === toExp (replaceAction str)
+ === toExp (replaceAction penv)
<:: "Id a => a -> Action -> Action"
--| "replace the channel running with given id",
"replaceBus"
- === toExp (replaceBus str)
+ === toExp (replaceBus penv)
<:: "Id a => a -> Number -> Action"
--| "replace the bus running with given id",
"(&:)"
- === toExp (replaceBus str)
+ === toExp (replaceBus penv)
<:: "Id a => a -> Number -> Action"
--| "replace the bus running with given id",
"fx"
- === toExp (fx str)
+ === toExp (fx penv)
<:: "Id a => a -> (Map -> Map) -> Action"
--| "apply the function to channel with given id",
"(#!)"
- === toExp (fx str)
+ === toExp (fx penv)
<:: "Id a => a -> (Map -> Map) -> Action"
--| "replace the bus running with given id",
- "all"
- === toExp allID
- <:: "Text"
- --| "special identifier to apply effects to all channels",
- "none"
- === toExp noneID
- <:: "Text"
- --| "special identifier to remove effects from all channels",
- "bpc"
- === toExp bpc
- <:: "Number"
- --| "current beats per cycle",
"hush"
- === toExp (hush str)
+ === toExp (hush penv)
<:: "Action"
--| "hush all channels",
- "once"
- === toExp (once str)
- <:: "Map -> Action"
- --| "play one cycle of the given zwirn",
- "tonce"
- === toExp (tonce str)
- <:: "Text -> Map -> Action"
- --| "play one cycle of the given zwirn on the given target",
"mute"
- === toExp (mute str)
+ === toExp (mute penv)
<:: "Id a => a -> Action"
--| "mute channel with given id",
"unmute"
- === toExp (unmute str)
+ === toExp (unmute penv)
<:: "Id a => a -> Action"
--| "unmute channel with given id",
"toggle"
- === toExp (toggle str)
+ === toExp (toggle penv)
<:: "Id a => a -> Action"
--| "toggle channel with given id",
"solo"
- === toExp (solo str)
+ === toExp (solo penv)
<:: "Id a => a -> Action"
--| "solo channel with given id",
"unsolo"
- === toExp (unsolo str)
+ === toExp (unsolo penv)
<:: "Id a => a -> Action"
--| "unsolo channel with given id",
"togglesolo"
- === toExp (togglesolo str)
+ === toExp (togglesolo penv)
<:: "Id a => a -> Action"
- --| "toggle solo channel with given id",
- "bpm"
- === toExp (bpm str)
- <:: "Number -> Action"
- --| "set the current bpm (beats per minute)",
- "cps"
- === toExp (cps str)
- <:: "Number -> Action"
- --| "set the current cps (cycles per second)",
- "resetcycles"
- === toExp (resetcycles str)
- <:: "Action"
- --| "resets the cycle count to 0",
- "setcycle"
- === toExp (setcycle str)
- <:: "Number -> Action"
- --| "set the current cycle to specific point in time",
- "disablelink"
- === toExp (disablelink str)
- <:: "Action"
- --| "disable ableton link",
- "enablelink"
- === toExp (enablelink str)
+ --| "toggle solo channel with given id"
+ ]
+
+playFunctionsDoux :: PlayEnv -> Map.Map Text AnnotatedExpression
+playFunctionsDoux penv =
+ Map.unions
+ [ "replace"
+ === toExp (replace penv)
+ <:: "Id a => a -> Map -> Action"
+ --| "replace the channel running with given id",
+ "($:)"
+ === toExp (replace penv)
+ <:: "Id a => a -> Map -> Action"
+ --| "replace the channel running with given id",
+ "replaceAction"
+ === toExp (replaceAction penv)
+ <:: "Id a => a -> Action -> Action"
+ --| "replace the channel running with given id",
+ "($!)"
+ === toExp (replaceAction penv)
+ <:: "Id a => a -> Action -> Action"
+ --| "replace the channel running with given id",
+ "replaceBus"
+ === toExp (replaceBus penv)
+ <:: "Id a => a -> Map -> Action"
+ --| "replace the bus running with given id",
+ "(&:)"
+ === toExp (replaceBus penv)
+ <:: "Id a => a -> Map -> Action"
+ --| "replace the bus running with given id",
+ "fx"
+ === toExp (fx penv)
+ <:: "Id a => a -> (Map -> Map) -> Action"
+ --| "apply the function to channel with given id",
+ "(#!)"
+ === toExp (fx penv)
+ <:: "Id a => a -> (Map -> Map) -> Action"
+ --| "replace the bus running with given id",
+ "hush"
+ === toExp (hush penv)
<:: "Action"
- --| "enable ableton link",
- "in"
- === toExp (execIn' str)
- <:: "Number -> Action -> Action"
- --| "start an action in a given amount of seconds",
- "inMod"
- === toExp (execMod str)
- <:: "Number -> Action -> Action"
- --| "start an action in a given amount of seconds",
- "transitionmap"
- === toExp (transition str)
- <:: "Id a => a -> (Number -> Map -> Map) -> Action"
- --| "",
- "transition"
- === toExp (transition' str)
- <:: "Id a => a -> Number -> b -> b -> (Map -> b -> Map) -> Action"
- --| ""
+ --| "hush all channels",
+ "mute"
+ === toExp (mute penv)
+ <:: "Id a => a -> Action"
+ --| "mute channel with given id",
+ "unmute"
+ === toExp (unmute penv)
+ <:: "Id a => a -> Action"
+ --| "unmute channel with given id",
+ "toggle"
+ === toExp (toggle penv)
+ <:: "Id a => a -> Action"
+ --| "toggle channel with given id",
+ "solo"
+ === toExp (solo penv)
+ <:: "Id a => a -> Action"
+ --| "solo channel with given id",
+ "unsolo"
+ === toExp (unsolo penv)
+ <:: "Id a => a -> Action"
+ --| "unsolo channel with given id",
+ "togglesolo"
+ === toExp (togglesolo penv)
+ <:: "Id a => a -> Action"
+ --| "toggle solo channel with given id"
]
diff --git a/src/zwirn-lang/Zwirn/Language/Compiler.hs b/src/zwirn-lang/Zwirn/Language/Compiler.hs
--- a/src/zwirn-lang/Zwirn/Language/Compiler.hs
+++ b/src/zwirn-lang/Zwirn/Language/Compiler.hs
@@ -26,6 +26,7 @@
-}
import Control.Concurrent (readMVar)
+import Control.Concurrent.MVar (MVar, modifyMVar_)
import Control.Exception (SomeException, try)
import Control.Monad
import Control.Monad.Except
@@ -37,18 +38,17 @@
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Text.IO (readFile)
-import Data.Version (showVersion)
-import Paths_zwirn (version)
import System.IO (hPutStrLn, stderr)
import Text.Read (readMaybe)
-import Zwirn.Core.Types (silence)
+import Zwirn.Core.Types (Value (..), silence, toList, unzwirn, value)
import Zwirn.Language.Block
-import Zwirn.Language.Builtin.Prelude (builtinEnvironmentWithStream, builtinNames)
+import Zwirn.Language.Builtin.Prelude (builtinEnvironmentWithPlayEnv, builtinNamesDoux, builtinNamesSuperDirt)
import Zwirn.Language.Environment
import Zwirn.Language.Evaluate
import Zwirn.Language.Location
import Zwirn.Language.Macro
import Zwirn.Language.Parser
+import Zwirn.Language.Play (PlayEnv (..), renderStatus)
import Zwirn.Language.Pretty
import qualified Zwirn.Language.Rotate as R
import Zwirn.Language.Simple
@@ -56,9 +56,6 @@
import Zwirn.Language.TypeCheck.Constraint
import Zwirn.Language.TypeCheck.Infer
import Zwirn.Language.TypeCheck.Types
-import Zwirn.Stream.Target (Targeted (..))
-import Zwirn.Stream.Types
-import Zwirn.Stream.UI
import Prelude hiding (readFile)
newtype CIMessage
@@ -75,14 +72,19 @@
cResetConfig :: IO String
}
+data StreamType = SuperDirt | Doux deriving (Eq, Show)
+
data CiConfig = CiConfig
{ ciConfigOverwriteBuiltin :: Bool,
- ciConfigDynamicTypes :: Bool
+ ciConfigDynamicTypes :: Bool,
+ ciConfigPrecision :: Rational,
+ ciConfigStreamType :: StreamType
}
data Environment
= Environment
- { tStream :: Stream,
+ { stateEnv :: MVar ExpressionMap,
+ playEnv :: PlayEnv,
intEnv :: InterpreterEnv,
confEnv :: Maybe ConfigEnv,
ciConfig :: CiConfig,
@@ -123,6 +125,9 @@
runCI :: Environment -> CI a -> IO (Either CIError a)
runCI env m = runExceptT $ evalStateT m env
+runCIEnv :: Environment -> CI a -> IO (Either CIError (a, Environment))
+runCIEnv env m = runExceptT $ runStateT m env
+
debug :: (MonadIO m) => String -> m ()
debug msg = liftIO $ hPutStrLn stderr $ "[zwirnzi] " <> msg
@@ -131,15 +136,24 @@
sy <- runParser input
runSyntax True sy
-compilerInterpreterBlock :: Int -> Text -> CI (CompilerOutput, Environment)
-compilerInterpreterBlock line input = do
+compilerInterpreterWithBlock :: Int -> Text -> CI (CompilerOutput, Environment, (Int, Int))
+compilerInterpreterWithBlock line input = do
blocks <- runBlocks 0 input
b <- runGetBlock line blocks
sys <- parseBlock b
r <- mapM (runSyntax True) sys
e <- get
- return (last r, e)
+ return (last r, e, (getBlockStart b, getBlockEnd b))
+getBlockStartEnd :: Int -> Text -> CI (Int, Int)
+getBlockStartEnd line input = do
+ blocks <- runBlocks 0 input
+ b <- runGetBlock line blocks
+ return (getBlockStart b, getBlockEnd b)
+
+compilerInterpreterBlock :: Int -> Text -> CI (CompilerOutput, Environment)
+compilerInterpreterBlock line input = compilerInterpreterWithBlock line input >>= \(co, env, _) -> return (co, env)
+
compilerInterpreterLine :: Int -> Text -> CI (CompilerOutput, Environment)
compilerInterpreterLine line input = do
blocks <- runBlocks 0 input
@@ -311,7 +325,9 @@
overwriteOk :: Text -> CI ()
overwriteOk name = do
overwrite <- gets (ciConfigOverwriteBuiltin . ciConfig)
- when (not overwrite && name `elem` builtinNames) $ throw $ OtherErr "Cannot overwrite builtin function. Please use OverwriteBuiltin."
+ strtyp <- gets (ciConfigStreamType . ciConfig)
+ let builtins = if strtyp == Doux then builtinNamesDoux else builtinNamesSuperDirt
+ when (not overwrite && name `elem` builtins) $ throw $ OtherErr "Cannot overwrite builtin function. Please use OverwriteBuiltin."
dynamicOk :: Text -> Scheme -> CI ()
dynamicOk name ty = do
@@ -343,8 +359,8 @@
exCtx <- checkHighlight ctx ex
case ty of
Forall _ (Qual _ _ (TypeCon "Action")) -> do
- str <- gets tStream
- liftIO $ evalAction str (fromExp exCtx)
+ stMV <- gets stateEnv
+ liftIO $ evalAction stMV (fromExp exCtx)
return $ OutEdits es
_ -> throw $ OtherErr "Can only execute actions!"
@@ -393,8 +409,8 @@
| isMapT ty = EZwirn $ getStateM (pure x)
| otherwise = EZwirn silence
modify (\env -> env {intEnv = extend (x, newEx, addDependency x ty) (intEnv env)})
- str <- gets tStream
- liftIO $ streamSet str x exCtx
+ stMV <- gets stateEnv
+ liftIO $ stateSet stMV x exCtx
else throw $ OtherErr "Cyclic dependency detected!"
| otherwise = throw $ OtherErr "Can only set basic types!"
@@ -424,9 +440,9 @@
if isBasicType ty
then do
ex <- interpret rot
- stmv <- gets (sState . tStream)
- prec <- gets (streamConfigPrecision . sConfig . tStream)
- st <- liftIO $ readMVar stmv
+ stMV <- gets stateEnv
+ prec <- gets (ciConfigPrecision . ciConfig)
+ st <- liftIO $ readMVar stMV
return $ OutMessage $ pack $ showWithStatePrec (realToFrac prec) st ex
else throw $ OtherErr $ "Can not show expressions of type: " ++ unpack (ppscheme ty)
@@ -473,8 +489,8 @@
resetEnvCommand :: CI CompilerOutput
resetEnvCommand = do
- str <- gets tStream
- modify (\env -> env {intEnv = builtinEnvironmentWithStream str})
+ penv <- gets playEnv
+ modify (\env -> env {intEnv = builtinEnvironmentWithPlayEnv penv})
return $ OutMessage "Environment reset to default!"
setCommand :: String -> CI CompilerOutput
@@ -487,31 +503,26 @@
envCommand :: CI CompilerOutput
envCommand = do
env <- gets (Map.toList . Map.filter isBasicExpression . eExpressions . intEnv)
- str <- gets tStream
- let builtin = Map.keys $ Map.filter isBasicExpression $ eExpressions $ builtinEnvironmentWithStream str
+ penv <- gets playEnv
+ let builtin = Map.keys $ Map.filter isBasicExpression $ eExpressions $ builtinEnvironmentWithPlayEnv penv
filtered = filter (\(k, _) -> k `notElem` builtin) env
return $ OutMessage $ T.intercalate "\n" $ map (\(k, Annotated _ ty _) -> k <> " :: " <> ppscheme ty) filtered
statusCommand :: CI CompilerOutput
statusCommand = do
- env <- get
- b <- liftIO (streamGetBPM (tStream env))
- pm <- liftIO $ readMVar (sPlayMap $ tStream env)
- return $ OutMessage $ renderStatus b pm
-
-renderStatus :: Double -> PlayMap -> Text
-renderStatus b pm = "zwirn " <> pack (showVersion version) <> "\ntempo: " <> pack (show b) <> "bpm\n" <> if null pm then "" else "active: " <> T.intercalate " | " ps
+ stMV <- gets stateEnv
+ pmMV <- gets (playMap . playEnv)
+ pm <- liftIO $ readMVar pmMV
+ st <- liftIO $ readMVar stMV
+ return $ OutMessage $ renderStatus (maybe 138 (getTempo st) (Map.lookup "_tempo" st)) pm
where
- ps = map (\(key, Targeted _ (st, _, _)) -> ppID key <> renderState sol st) $ Map.toList pm
- sol = noSolo pm
- renderState True Normal = ""
- renderState False Normal = " (not soloed)"
- renderState _ Solo = " (solo)"
- renderState _ Mute = " (muted)"
-
--- | true if no pattern has a solo status
-noSolo :: PlayMap -> Bool
-noSolo pm = all (\(_, Targeted _ (ps, _, _)) -> ps /= Solo) $ Map.toList pm
+ getTempo :: ExpressionMap -> Expression -> Double
+ getTempo st x = case vs of
+ [] -> 138
+ ((Value v _ _, _) : _) -> v
+ where
+ z = fromExp x :: Zwirn Double
+ vs = toList $ unzwirn z 0 st
isNumberT :: Scheme -> Bool
isNumberT (Forall _ (Qual _ _ (TypeCon "Number"))) = True
@@ -524,3 +535,23 @@
isMapT :: Scheme -> Bool
isMapT (Forall _ (Qual _ _ (TypeCon "Map"))) = True
isMapT _ = False
+
+stateSet :: MVar ExpressionMap -> T.Text -> Expression -> IO ()
+stateSet stMV x ex = modifyMVar_ stMV (return . Map.insert x ex)
+
+updateState :: MVar ExpressionMap -> [ExpressionMap] -> IO ()
+updateState _ [] = return ()
+updateState stmv (st : _) = modifyMVar_ stmv (const $ return st)
+
+evalAction :: MVar ExpressionMap -> Zwirn Expression -> IO ()
+evalAction stMV z = do
+ st <- readMVar stMV
+ let exps = toList $ unzwirn z 0 st
+ sts = map snd exps
+ exs = map (value . fst) exps
+
+ updateState stMV sts
+ mapM_ evalActionExp exs
+ where
+ evalActionExp (EAction i) = i
+ evalActionExp _ = return ()
diff --git a/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs b/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs
--- a/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs
+++ b/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs
@@ -35,7 +35,6 @@
import Data.Maybe (fromJust, fromMaybe)
import Data.Text (Text, pack)
import qualified Data.Text as T
-import Sound.Tidal.Clock (getCPS, getCycleTime)
import Zwirn.Core.Cord
import Zwirn.Core.Core (withState)
import Zwirn.Core.Lib.Cord
@@ -49,14 +48,12 @@
import Zwirn.Language.Evaluate.Convert
import Zwirn.Language.Evaluate.Expression
import Zwirn.Language.Location (SrcLoc)
+import Zwirn.Language.Play
import Zwirn.Language.Syntax
-import Zwirn.Stream.Target (Targeted (..))
-import Zwirn.Stream.Types (Identifier (..), Stream (..), StreamConfig (streamConfigClock))
-import Zwirn.Stream.UI
-import qualified Zwirn.Stream.UI as Stream
instance State Tree ExpressionMap SrcLoc where
beatsPerCycle = (\(ENum x) -> x) <$> getStateNWith (pure $ T.pack "_beatsPerCycle") (pure 8)
+ cyclesPerSecond = (\(ENum x) -> x) <$> getStateNWith (pure $ T.pack "_cps") (pure 0.575)
insert :: (Text, Expression) -> ExpressionMap -> ExpressionMap
insert (k, x) = Map.insert k x
@@ -166,95 +163,47 @@
bpc :: Zwirn Expression
bpc = getStateN (pure "_beatsPerCycle")
+tempo :: Zwirn Expression
+tempo = getStateN (pure "_tempo")
+
allID :: Zwirn Text
allID = pure "_all"
noneID :: Zwirn Text
noneID = pure "_none"
-replace :: Stream -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn (IO ())
-replace str iz mz = (\f -> f $ EMap <$> mz) . streamReplace str . toTargetedID <$> iz
-
-replaceAction :: Stream -> Zwirn Expression -> Zwirn Expression -> Zwirn (IO ())
-replaceAction str iz mz = (\f -> f mz) . streamReplaceAction str . toID <$> iz
-
-replaceBus :: Stream -> Zwirn Expression -> Zwirn Expression -> Zwirn (IO ())
-replaceBus str iz mz = (\f -> f mz) . streamReplaceBus str <$> toBusID iz
-
-hush :: Stream -> Zwirn (IO ())
-hush str = pure $ streamHush str
-
-mute :: Stream -> Zwirn Expression -> Zwirn (IO ())
-mute str iz = streamMute str . toID <$> iz
-
-once :: Stream -> Zwirn Expression -> Zwirn (IO ())
-once str iz = pure (streamFirst str iz)
-
-tonce :: Stream -> Zwirn Text -> Zwirn Expression -> Zwirn (IO ())
-tonce str tz iz = flip (streamFirstTarget str) iz <$> tz
-
-unmute :: Stream -> Zwirn Expression -> Zwirn (IO ())
-unmute str iz = streamUnmute str . toID <$> iz
-
-toggle :: Stream -> Zwirn Expression -> Zwirn (IO ())
-toggle str iz = streamToggle str . toID <$> iz
-
-solo :: Stream -> Zwirn Expression -> Zwirn (IO ())
-solo str iz = streamSolo str . toID <$> iz
-
-togglesolo :: Stream -> Zwirn Expression -> Zwirn (IO ())
-togglesolo str iz = streamToggleSolo str . toID <$> iz
-
-unsolo :: Stream -> Zwirn Expression -> Zwirn (IO ())
-unsolo str iz = streamUnsolo str . toID <$> iz
-
-fx :: Stream -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn (IO ())
-fx str key fxz = (\f -> f fxz) . streamSetFx str . toID <$> key
-
-bpm :: Stream -> Zwirn Double -> Zwirn (IO ())
-bpm str iz = streamSetBPM str . realToFrac <$> iz
+replace :: PlayEnv -> Zwirn Expression -> Zwirn ExpressionMap -> Zwirn (IO ())
+replace str iz mz = (\f -> f $ EMap <$> addOrbit) . playReplace str . toTargetedID <$> iz
+ where
+ orbit = (\(Targeted _ i) -> case i of TextID _ -> ENum 0; NumID n -> ENum $ fromIntegral n) . toTargetedID <$> iz
+ addOrbit = mz `unionL` singleton (pure "orbit") orbit
-cps :: Stream -> Zwirn Double -> Zwirn (IO ())
-cps str iz = streamSetCPS str . realToFrac <$> iz
+replaceAction :: PlayEnv -> Zwirn Expression -> Zwirn Expression -> Zwirn (IO ())
+replaceAction str iz mz = (\f -> f mz) . playReplaceAction str . toID <$> iz
-setcycle :: Stream -> Zwirn Double -> Zwirn (IO ())
-setcycle str iz = streamSetCycle str . realToFrac <$> iz
+replaceBus :: PlayEnv -> Zwirn Expression -> Zwirn Expression -> Zwirn (IO ())
+replaceBus str iz mz = (\f -> f mz) . playReplaceBus str <$> toBusID iz
-resetcycles :: Stream -> Zwirn (IO ())
-resetcycles str = pure $ streamResetCycles str
+hush :: PlayEnv -> Zwirn (IO ())
+hush str = pure $ playHush str
-enablelink :: Stream -> Zwirn (IO ())
-enablelink str = pure $ streamEnableLink str
+mute :: PlayEnv -> Zwirn Expression -> Zwirn (IO ())
+mute str iz = playMute str . toID <$> iz
-disablelink :: Stream -> Zwirn (IO ())
-disablelink str = pure $ streamDisableLink str
+unmute :: PlayEnv -> Zwirn Expression -> Zwirn (IO ())
+unmute str iz = playUnmute str . toID <$> iz
-execIn :: Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
-execIn dz acz = execInSecs_ <$> dz <*> acz
- where
- execInSecs_ :: Double -> IO () -> IO ()
- execInSecs_ d ac = void $ forkIO $ threadDelay (floor $ d * 1000000) >> ac
+toggle :: PlayEnv -> Zwirn Expression -> Zwirn (IO ())
+toggle str iz = playToggle str . toID <$> iz
-execIn' :: Stream -> Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
-execIn' str dz acz = execInCycs_ <$> dz <*> acz
- where
- execInCycs_ :: Double -> IO () -> IO ()
- execInCycs_ d ac = do
- xcps <- getCPS (streamConfigClock $ sConfig str) (sClockRef str)
- void $ forkIO $ threadDelay (floor $ d * realToFrac xcps * 1000000) >> ac
+solo :: PlayEnv -> Zwirn Expression -> Zwirn (IO ())
+solo str iz = playSolo str . toID <$> iz
-execMod :: Stream -> Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
-execMod str dz acz = execMod_ <$> dz <*> acz
- where
- execMod_ :: Double -> IO () -> IO ()
- execMod_ d ac = do
- xcps <- getCPS (streamConfigClock $ sConfig str) (sClockRef str)
- now <- getCycleTime (streamConfigClock $ sConfig str) (sClockRef str)
- let del = d - mod' (realToFrac now) d
- void $ forkIO $ threadDelay (floor $ del * realToFrac xcps * 1000000) >> ac
+togglesolo :: PlayEnv -> Zwirn Expression -> Zwirn (IO ())
+togglesolo str iz = playToggleSolo str . toID <$> iz
-transition :: Stream -> Zwirn Expression -> Zwirn (Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn (IO ())
-transition str kz = liftA2 (Stream.transition str) (toID <$> kz)
+unsolo :: PlayEnv -> Zwirn Expression -> Zwirn (IO ())
+unsolo str iz = playUnsolo str . toID <$> iz
-transition' :: Stream -> Zwirn Expression -> Zwirn Time -> Zwirn Expression -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn (IO ())
-transition' str kz dur def sig fun = (\k -> Stream.transition' str k dur def sig fun) . toID <$> kz
+fx :: PlayEnv -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn (IO ())
+fx str key fxz = (\f -> f fxz) . playSetFx str . toID <$> key
diff --git a/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs b/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs
--- a/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs
+++ b/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs
@@ -9,14 +9,15 @@
import Zwirn.Language.Syntax
-- parses source code
-parseAndGetInfoAt :: T.Text -> Position -> CI (Maybe (T.Text, RealSrcLoc))
-parseAndGetInfoAt doc pos@(Position l _) = do
+parseAndGetInfoAt :: Bool -> T.Text -> Position -> CI (Maybe (T.Text, RealSrcLoc))
+parseAndGetInfoAt wrap doc pos@(Position l _) = do
+ let wrapper = if wrap then wrapCodeBlock else id
syntax <- getSyntaxLine l doc
case syntaxGetNodeAt pos =<< syntax of
- Just (Located (SrcLoc p) (TVar x)) -> (\mz -> mz >>= \z -> Just (z, p)) <$> infoMarkdown x
- Just (Located (SrcLoc p) (TNum x)) -> return $ Just (wrapCodeBlock $ x <> " :: Number", p)
- Just (Located (SrcLoc p) (TText x)) -> return $ Just (wrapCodeBlock $ x <> " :: Text", p)
- Just (Located (SrcLoc p) TRest) -> return $ Just (wrapCodeBlock "~ :: a", p)
+ Just (Located (SrcLoc p) (TVar x)) -> (\mz -> mz >>= \z -> Just (z, p)) <$> infoMarkdown wrap x
+ Just (Located (SrcLoc p) (TNum x)) -> return $ Just (wrapper $ x <> " :: Number", p)
+ Just (Located (SrcLoc p) (TText x)) -> return $ Just (wrapper $ x <> " :: Text", p)
+ Just (Located (SrcLoc p) TRest) -> return $ Just (wrapper "~ :: a", p)
Just _ -> return Nothing
Nothing -> return Nothing
@@ -45,12 +46,13 @@
)
else Nothing
-infoMarkdown :: T.Text -> CI (Maybe T.Text)
-infoMarkdown n = do
+infoMarkdown :: Bool -> T.Text -> CI (Maybe T.Text)
+infoMarkdown wrap n = do
+ let wrapper = if wrap then wrapCodeBlock else id
env <- gets intEnv
case lookupFull n env of
- Just (Annotated _ t (Just d)) -> return $ Just $ wrapCodeBlock (n <> " :: " <> ppscheme t) <> " \n\n" <> d
- Just (Annotated _ t Nothing) -> return $ Just $ wrapCodeBlock $ n <> " :: " <> ppscheme t
+ Just (Annotated _ t (Just d)) -> return $ Just $ wrapper (n <> " :: " <> ppscheme t) <> " \n\n" <> d
+ Just (Annotated _ t Nothing) -> return $ Just $ wrapper $ n <> " :: " <> ppscheme t
Nothing -> return Nothing
wrapCodeBlock :: T.Text -> T.Text
diff --git a/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs b/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs
--- a/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs
+++ b/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs
@@ -6,10 +6,9 @@
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text as T (Text, filter, unpack)
import Zwirn.Language (Syntax (..), Term (..), catchMany, parseBlock)
-import Zwirn.Language.Compiler (CI, CompilerOutput (..), Environment (..), filterErrors, noSolo, runBlocks, runCommand)
+import Zwirn.Language.Compiler (CI, CompilerOutput (..), Environment (..), filterErrors, runBlocks, runCommand)
import Zwirn.Language.Location (Located (..), Position (..), RealSrcLoc (..), SrcLoc (..))
-import Zwirn.Stream.Target (Targeted (..))
-import Zwirn.Stream.Types (Identifier (..), PlayMap, PlayState (..), Stream (..))
+import Zwirn.Language.Play (Identifier (..), PlayEnv (..), PlayMap, PlayState (..), Targeted (..), noSolo)
data Hint
= Hint
@@ -27,10 +26,10 @@
ch <- getCommandHints ss
return $ sh ++ ch
--- | inlay hints above stream actions of the form `id &: exp`, for displaying the play state of the according expression
+-- | inlay hints above stream actions of the form `id $: exp`, for displaying the play state of the according expression
getStreamHints :: [Syntax] -> CI [Hint]
getStreamHints ss = do
- pm <- gets (sPlayMap . tStream) >>= liftIO . readMVar
+ pm <- gets (playMap . playEnv) >>= liftIO . readMVar
let chans = map findStreamPattern ss
return $ mapMaybe (resolvePlayState pm) chans
diff --git a/src/zwirn-lang/Zwirn/Language/Lexer.x b/src/zwirn-lang/Zwirn/Language/Lexer.x
--- a/src/zwirn-lang/Zwirn/Language/Lexer.x
+++ b/src/zwirn-lang/Zwirn/Language/Lexer.x
@@ -18,6 +18,7 @@
, setInitialLineNum
, lineLexer
, typeLexer
+ , tokenise
) where
{-
@@ -381,6 +382,15 @@
go = do
output <- lineLexer >> alexMonadScan
if lValue output == EOF
+ then pure [output]
+ else ((output) :) <$> go
+
+tokenise :: Text -> Either String [Lexeme]
+tokenise input = runAlex input go
+ where
+ go = do
+ output <- alexMonadScan
+ if lValue output == EOF
then pure [output]
else ((output) :) <$> go
}
diff --git a/src/zwirn-lang/Zwirn/Language/Location.hs b/src/zwirn-lang/Zwirn/Language/Location.hs
--- a/src/zwirn-lang/Zwirn/Language/Location.hs
+++ b/src/zwirn-lang/Zwirn/Language/Location.hs
@@ -87,7 +87,11 @@
isContained :: Position -> Located a -> Bool
isContained (Position _ _) (Located NoLoc _) = False
-isContained (Position lp cp) (Located (SrcLoc (RealSrcLoc _ lst cst len cen)) _) = lst <= lp && lp <= len && cst <= cp && cp <= cen
+isContained (Position lp cp) (Located (SrcLoc (RealSrcLoc _ lst cst len cen)) _)
+ | lp == lst && lst == len = cst <= cp && cp <= cen
+ | lp == lst = cst <= cp
+ | lp == len = cp <= cen
+ | otherwise = lst < lp && lp < len
findWithPos :: Position -> [Located a] -> Maybe (Located a)
findWithPos p = find (isContained p)
diff --git a/src/zwirn-lang/Zwirn/Language/Play.hs b/src/zwirn-lang/Zwirn/Language/Play.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Play.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE DeriveFunctor #-}
+
+module Zwirn.Language.Play where
+
+{-
+ Play.hs - defines active zwirns
+ Copyright (C) 2026, Martin Gius
+
+ This library is free software: you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation, either version 3 of the License, or
+ (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this library. If not, see .
+-}
+
+import Control.Concurrent.MVar (MVar, modifyMVar_)
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Version (showVersion)
+import Paths_zwirn (version)
+import Zwirn.Core.Lib.Core (apply)
+import Zwirn.Core.Lib.Structure (segment)
+import Zwirn.Language.Evaluate.Expression (Expression, Zwirn)
+
+data PlayEnv = PlayEnv
+ { playMap :: MVar PlayMap,
+ actionMap :: MVar ActionMap,
+ busMap :: MVar BusMap
+ }
+
+type TargetName = Text
+
+-- | wraps a type in a list of target names
+data Targeted a
+ = Targeted
+ { targets :: [TargetName],
+ tValue :: a
+ }
+ deriving (Functor)
+
+data PlayState
+ = Normal
+ | Solo
+ | Mute
+ deriving (Eq, Show)
+
+-- | type for overloading channel IDs
+data Identifier
+ = TextID Text
+ | NumID Int
+ deriving (Eq, Show, Ord)
+
+-- | a playmap assosciates an channel ID with a PlayState, a zwirn and an fx function to be applied to the zwirn before querying
+type PlayMap =
+ Map.Map Identifier (Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))))
+
+-- | an actionmap associates an ID with an zwirn of actions (i.e. values of type IO ())
+type ActionMap = Map.Map Identifier (Zwirn Expression)
+
+-- | a busmap associates a busnumber with a zwirn of numbers
+type BusMap = Map.Map Int (Targeted (Zwirn Expression))
+
+playReplace :: PlayEnv -> Targeted Identifier -> Zwirn Expression -> IO ()
+playReplace _ (Targeted _ (TextID "_all")) _ = return ()
+playReplace _ (Targeted _ (TextID "_none")) _ = return ()
+playReplace penv (Targeted ts key) p = modifyMVar_ (playMap penv) (return . Map.alter alterFunc key)
+ where
+ alterFunc Nothing = Just (Targeted ts (Normal, p, Nothing))
+ alterFunc (Just (Targeted _ (_, _, fx))) = Just (Targeted ts (Normal, p, fx))
+
+playReplaceBus :: PlayEnv -> Targeted Int -> Zwirn Expression -> IO ()
+playReplaceBus penv (Targeted ts key) p = modifyMVar_ (busMap penv) (return . Map.insert key (Targeted ts $ segment (pure 128) p))
+
+playReplaceAction :: PlayEnv -> Identifier -> Zwirn Expression -> IO ()
+playReplaceAction _ (TextID "_all") _ = return ()
+playReplaceAction _ (TextID "_none") _ = return ()
+playReplaceAction penv key p = modifyMVar_ (actionMap penv) (return . Map.insert key p)
+
+playHush :: PlayEnv -> IO ()
+playHush penv = do
+ modifyMVar_ (playMap penv) (return . const Map.empty)
+ modifyMVar_ (actionMap penv) (return . const Map.empty)
+ modifyMVar_ (busMap penv) (return . const Map.empty)
+
+playSetFx :: PlayEnv -> Identifier -> Zwirn (Zwirn Expression -> Zwirn Expression) -> IO ()
+playSetFx penv (TextID "_all") fx = modifyMVar_ (playMap penv) (return . fmap (fmap (\(st, p, _) -> (st, p, Just fx))))
+playSetFx penv (TextID "_none") _ = modifyMVar_ (playMap penv) (return . fmap (fmap (\(st, p, _) -> (st, p, Nothing))))
+playSetFx penv key fx = modifyMVar_ (playMap penv) (return . Map.update (\(Targeted ts (st, p, _)) -> Just $ Targeted ts (st, p, Just fx)) key)
+
+playToggle :: PlayEnv -> Identifier -> IO ()
+playToggle penv key = case key of
+ (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
+ _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
+ where
+ toggle (Mute, p, fx) = (Normal, p, fx)
+ toggle (_, p, fx) = (Mute, p, fx)
+
+playMute :: PlayEnv -> Identifier -> IO ()
+playMute penv key = case key of
+ TextID "_all" -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
+ TextID "_none" -> playUnmute penv (TextID "_all")
+ _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
+ where
+ toggle (Normal, p, fx) = (Mute, p, fx)
+ toggle (Solo, p, fx) = (Mute, p, fx)
+ toggle x = x
+
+playUnmute :: PlayEnv -> Identifier -> IO ()
+playUnmute penv key = case key of
+ TextID "_all" -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
+ TextID "_none" -> playMute penv (TextID "_all")
+ _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
+ where
+ toggle (Mute, p, fx) = (Normal, p, fx)
+ toggle x = x
+
+playSolo :: PlayEnv -> Identifier -> IO ()
+playSolo penv key = case key of
+ (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
+ (TextID "_none") -> playUnsolo penv (TextID "_all")
+ _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
+ where
+ toggle (Normal, p, fx) = (Solo, p, fx)
+ toggle (Mute, p, fx) = (Solo, p, fx)
+ toggle x = x
+
+playUnsolo :: PlayEnv -> Identifier -> IO ()
+playUnsolo penv key = case key of
+ (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
+ (TextID "_none") -> playSolo penv (TextID "_all")
+ _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
+ where
+ toggle (Solo, p, fx) = (Normal, p, fx)
+ toggle x = x
+
+playToggleSolo :: PlayEnv -> Identifier -> IO ()
+playToggleSolo penv key = case key of
+ (TextID "_all") -> modifyMVar_ (playMap penv) (return . fmap (fmap toggle))
+ _ -> modifyMVar_ (playMap penv) (return . Map.adjust (fmap toggle) key)
+ where
+ toggle (Solo, p, fx) = (Normal, p, fx)
+ toggle (_, p, fx) = (Solo, p, fx)
+
+applyFx :: Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))) -> Targeted (Zwirn Expression)
+applyFx (Targeted ts (_, x, Nothing)) = Targeted ts x
+applyFx (Targeted ts (_, x, Just fx)) = Targeted ts (apply fx x)
+
+resolvePlayMap :: PlayMap -> [Targeted (Zwirn Expression)]
+resolvePlayMap pm = if null ss then map applyFx rs else map applyFx ss
+ where
+ ps = Map.elems pm
+ ss = filter (\(Targeted _ (x, _, _)) -> x == Solo) ps
+ rs = filter (\(Targeted _ (x, _, _)) -> x == Normal) ps
+
+renderStatus :: Double -> PlayMap -> Text
+renderStatus b pm = "zwirn " <> T.pack (showVersion version) <> "\ntempo: " <> T.pack (show b) <> "bpm\n" <> if null pm then "" else "active: " <> T.intercalate " | " ps
+ where
+ ps = map (\(key, Targeted _ (st, _, _)) -> ppID key <> renderState sol st) $ Map.toList pm
+ sol = noSolo pm
+ renderState True Normal = ""
+ renderState False Normal = " (not soloed)"
+ renderState _ Solo = " (solo)"
+ renderState _ Mute = " (muted)"
+ ppID (TextID t) = t
+ ppID (NumID i) = T.show i
+
+-- | true if no pattern has a solo status
+noSolo :: PlayMap -> Bool
+noSolo pm = all (\(_, Targeted _ (ps, _, _)) -> ps /= Solo) $ Map.toList pm
diff --git a/src/zwirn-lang/Zwirn/Language/Pretty.hs b/src/zwirn-lang/Zwirn/Language/Pretty.hs
--- a/src/zwirn-lang/Zwirn/Language/Pretty.hs
+++ b/src/zwirn-lang/Zwirn/Language/Pretty.hs
@@ -28,7 +28,6 @@
import Zwirn.Language.Syntax
import Zwirn.Language.TypeCheck.Constraint (TypeError (..))
import Zwirn.Language.TypeCheck.Types
-import Zwirn.Stream.Types (Identifier (..))
instance (Pretty a) => Pretty (Located a) where
pretty (Located _ x) = pretty x
@@ -86,10 +85,6 @@
parensIf True = parens
parensIf False = id
-instance Pretty Identifier where
- pretty (TextID t) = pretty t
- pretty (NumID i) = pretty i
-
instance Pretty Type where
pretty (TypeArr a b) = parensIf (isArrow a) (pretty a) <+> "->" <+> pretty b
where
@@ -132,9 +127,6 @@
ppTermHasType :: (LocTerm, Scheme) -> T.Text
ppTermHasType (t, s) = renderDoc $ pretty t <+> "::" <+> pretty s
-
-ppID :: Identifier -> T.Text
-ppID = render
instance Pretty TypeError where
pretty (UnificationFail (Located _ (a, b))) = "Cannot unify types:" <+> pretty a <+> "~" <+> pretty b
diff --git a/src/zwirn-lang/Zwirn/Stream/Handshake.hs b/src/zwirn-lang/Zwirn/Stream/Handshake.hs
deleted file mode 100644
--- a/src/zwirn-lang/Zwirn/Stream/Handshake.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-module Zwirn.Stream.Handshake where
-
-import Control.Concurrent.MVar (MVar, swapMVar)
-import Control.Monad (void)
-import Data.Maybe (catMaybes, isJust)
-import qualified Sound.Osc as O
-import qualified Sound.Osc.Transport.Fd.Udp as O
-import Zwirn.Stream.Target
-
--- handshake is in the responsibility of a specific listener implementation
--- these functions can be used to implement it
-
-sendHandshake :: O.Udp -> RemoteAddress -> IO ()
-sendHandshake udp = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" [])
-
-isHandshakeMsg :: O.Message -> Bool
-isHandshakeMsg (O.Message "/dirt/hello" _) = True
-isHandshakeMsg (O.Message "/dirt/handshake/reply" _) = True
-isHandshakeMsg _ = False
-
-actOnHandshake :: O.Message -> O.Udp -> RemoteAddress -> MVar [Int] -> IO ()
-actOnHandshake (O.Message "/dirt/hello" _) udp remote _ = sendHandshake udp remote
-actOnHandshake (O.Message "/dirt/handshake/reply" xs) _ _ bussesMV = void $ swapMVar bussesMV $ bufferIndices xs
- where
- bufferIndices [] = []
- bufferIndices (x : xs')
- | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
- | otherwise = bufferIndices xs'
-actOnHandshake _ _ _ _ = return ()
diff --git a/src/zwirn-lang/Zwirn/Stream/Listen.hs b/src/zwirn-lang/Zwirn/Stream/Listen.hs
deleted file mode 100644
--- a/src/zwirn-lang/Zwirn/Stream/Listen.hs
+++ /dev/null
@@ -1,48 +0,0 @@
-module Zwirn.Stream.Listen where
-
-import Data.Bifunctor (first)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8, encodeUtf8)
-import qualified Network.Socket as N
-import Sound.Osc as O
-import Sound.Osc.Transport.Fd.Udp as O
-import Zwirn.Language.Evaluate (Expression (..))
-import Zwirn.Stream.Handshake
-import Zwirn.Stream.Types (Stream (..))
-import Zwirn.Stream.UI
-
-type RemoteAddress = N.SockAddr
-
-listen :: Stream -> IO ()
-listen str = recvMessageFrom (sLocal str) >>= act str >> listen str
-
-recvMessageFrom :: O.Udp -> IO (Maybe Message, RemoteAddress)
-recvMessageFrom loc = fmap (first packet_to_message) (recvFrom loc)
-
-act :: Stream -> (Maybe O.Message, RemoteAddress) -> IO ()
-act str (Just (Message "/ping" []), remote) = replyOk (sLocal str) remote
-act str (Just (Message "/ctrl" [AsciiString key, Double val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum val) >> replyOk (sLocal str) remote
-act str (Just (Message "/ctrl" [AsciiString key, Float val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ realToFrac val) >> replyOk (sLocal str) remote
-act str (Just (Message "/ctrl" [AsciiString key, Int32 val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ fromIntegral val) >> replyOk (sLocal str) remote
-act str (Just (Message "/ctrl" [AsciiString key, Int64 val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ fromIntegral val) >> replyOk (sLocal str) remote
-act str (Just (Message "/ctrl" [AsciiString key, AsciiString val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ EText $ toUTF8 val) >> replyOk (sLocal str) remote
-act str (Just m, remote) =
- if isHandshakeMsg m
- then actOnHandshake m (sLocal str) remote (sBusses str)
- else replyError (sLocal str) remote ("Unhandeled Message: " ++ show m)
-act _ _ = return ()
-
-reply :: O.Udp -> RemoteAddress -> O.Packet -> IO ()
-reply loc remote msg = O.sendTo loc msg remote
-
-replyOk :: O.Udp -> RemoteAddress -> IO ()
-replyOk loc = flip (reply loc) (O.p_message "/ok" [])
-
-replyError :: O.Udp -> RemoteAddress -> String -> IO ()
-replyError loc remote err = reply loc remote (O.p_message "/error" [utf8String err])
-
-utf8String :: String -> O.Datum
-utf8String s = O.AsciiString $ encodeUtf8 $ T.pack s
-
-toUTF8 :: O.Ascii -> T.Text
-toUTF8 = decodeUtf8
diff --git a/src/zwirn-lang/Zwirn/Stream/Process.hs b/src/zwirn-lang/Zwirn/Stream/Process.hs
deleted file mode 100644
--- a/src/zwirn-lang/Zwirn/Stream/Process.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use mapMaybe" #-}
-
-module Zwirn.Stream.Process where
-
-import Control.Concurrent.MVar (MVar, modifyMVar_, readMVar)
-import Data.Bifunctor (first)
-import Data.List (mapAccumL)
-import qualified Data.Map as Map
-import Data.Maybe (catMaybes)
-import qualified Data.Text as T
-import Data.Tuple (swap)
-import qualified Sound.Osc as O
-import qualified Sound.Osc.Transport.Fd.Udp as O
-import Sound.Tidal.Clock
-import qualified Sound.Tidal.Clock as Clock
-import Sound.Tidal.Link
-import Zwirn.Core.Lib.Core (apply)
-import Zwirn.Core.Query
-import qualified Zwirn.Core.Time as Z
-import Zwirn.Language.Evaluate.Expression
-import Zwirn.Stream.Target
-import Zwirn.Stream.Types
-
-tickAction ::
- MVar PlayMap -> -- maps from channels to expressions
- MVar ActionMap -> -- maps from channels to expressions
- MVar BusMap -> -- maps from busses to expressions
- MVar ExpressionMap -> -- state map
- MVar [Int] -> -- bus mapping
- TargetMap -> -- targets
- O.Udp -> -- local address
- Time -> -- precision
- (Time, Time) -> -- arc of the current tick
- Double -> -- nudge
- ClockConfig -> -- configuration of the clock
- ClockRef -> -- reference to the clock
- (SessionState, SessionState) ->
- IO ()
-tickAction zMV actionMapMV busMapMV stMV bussesMV targetMap local prec (star, end) nudge cconf cref (ss, _) = do
- cps <- Clock.getCPS cconf cref
- vs <- processPlayMap prec (star, end) cps zMV stMV
- bs <- processBusMap prec (star, end) busMapMV stMV bussesMV
- processActionMap prec (star, end) cps actionMapMV stMV
- mapM_ (stampAndSend targetMap False local nudge cconf cref ss) vs
- mapM_ (stampAndSend targetMap True local nudge cconf cref ss . (\(Targeted ts (t, m)) -> Targeted ts (t, Just m))) bs
-
-processPlayMap :: Time -> (Time, Time) -> Time -> MVar PlayMap -> MVar ExpressionMap -> IO [Targeted (Z.Time, Maybe (T.Text -> O.Message))]
-processPlayMap prec (star, end) cps zMV stMV = do
- pm <- readMVar zMV
- let ps = resolvePlayMap pm
- st <- readMVar stMV
-
- let (enst, vs) = mapAccumL (\ !s (Targeted ts p) -> swap $ first (Targeted ts) $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
-
- modifyMVar_ stMV (const $ return enst)
- let func (t, ex) = expressionToMessage (fromIntegral (floor t :: Int)) (realToFrac cps) ex >>= \m -> return (t, m)
-
- concat <$> mapM (\targ -> (\(Targeted ts xs) -> mapM (fmap (Targeted ts) . func) xs) targ) vs
-
-processActionMap :: Time -> (Time, Time) -> Time -> MVar ActionMap -> MVar ExpressionMap -> IO ()
-processActionMap prec (star, end) cps zMV stMV = do
- pm <- readMVar zMV
- let ps = Map.elems pm
- st <- readMVar stMV
-
- let (enst, vs) = mapAccumL (\ !s p -> swap $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
-
- modifyMVar_ stMV (const $ return enst)
- mapM_ (\(t, ex) -> expressionToMessage (fromIntegral (floor t :: Int)) (realToFrac cps) ex >>= \m -> return (t, m)) (concat vs)
-
-processBusMap :: Time -> (Time, Time) -> MVar BusMap -> MVar ExpressionMap -> MVar [Int] -> IO [Targeted (Z.Time, T.Text -> O.Message)]
-processBusMap prec (star, end) busMV stMV bussesMV = do
- bm <- readMVar busMV
- let bs = Map.toList bm
- busses <- readMVar bussesMV
- st <- readMVar stMV
-
- concat <$> mapM (\(i, Targeted ts x) -> map (Targeted ts) <$> busToMessage prec (star, end) busses st (i, x)) bs
-
-busToMessage :: Time -> (Time, Time) -> [Int] -> ExpressionMap -> (Int, Zwirn Expression) -> IO [(Z.Time, T.Text -> O.Message)]
-busToMessage prec (star, end) busses st (i, p) = do
- let vs = findAllValuesWithTimePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) st p
-
- mapM (\(t, ex) -> busExpressionToMessage (toBus busses i) ex >>= \m -> return (t, m)) vs
-
-toBus :: [Int] -> Int -> Int
-toBus [] i = i
-toBus xs i = xs !! (i `mod` length xs)
-
-applyFx :: Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))) -> Targeted (Zwirn Expression)
-applyFx (Targeted ts (_, x, Nothing)) = Targeted ts x
-applyFx (Targeted ts (_, x, Just fx)) = Targeted ts (apply fx x)
-
-resolvePlayMap :: PlayMap -> [Targeted (Zwirn Expression)]
-resolvePlayMap pm = if null ss then map applyFx rs else map applyFx ss
- where
- ps = Map.elems pm
- ss = filter (\(Targeted _ (x, _, _)) -> x == Solo) ps
- rs = filter (\(Targeted _ (x, _, _)) -> x == Normal) ps
-
-align :: Time -> Time -> Time
-align prec t = fromIntegral (floor $ t / prec :: Int) * prec
-
-----------------------------------------------------------
--------------- expressions --> osc messages --------------
-----------------------------------------------------------
-
-expressionToMessage :: Double -> Double -> Expression -> IO (Maybe (T.Text -> O.Message))
-expressionToMessage cyc cps ex = do
- os <- expressionToOSC ex
- let additionalData = [O.string "cps", O.float cps, O.string "cycle", O.float cyc]
- if null os
- then return Nothing
- else return $ Just $ \pat -> O.message (T.unpack pat) (additionalData ++ os)
-
-busExpressionToMessage :: Int -> Expression -> IO (T.Text -> O.Message)
-busExpressionToMessage bus ex = do
- os <- expressionToOSC ex
- return $ \path -> O.message (T.unpack path) (O.int32 bus : os)
-
-expressionToOSC :: Expression -> IO [O.Datum]
-expressionToOSC (ENum n) = return [O.float n]
-expressionToOSC (EText n) = return [O.string $ T.unpack n]
-expressionToOSC (EMap m) = concat <$> mapM (\(k, v) -> expressionToOSC v >>= \xs -> return $ O.string (T.unpack k) : xs) (Map.toList m)
-expressionToOSC (EAction a) = a >> return []
-expressionToOSC _ = return []
-
-----------------------------------------------
--------------- sending messages --------------
-----------------------------------------------
-
-defaultLatency :: Double
-defaultLatency = 0.2
-
-stampAndSend :: TargetMap -> Bool -> O.Udp -> Double -> ClockConfig -> ClockRef -> SessionState -> Targeted (Z.Time, Maybe (T.Text -> O.Message)) -> IO ()
-stampAndSend _ _ _ _ _ _ _ (Targeted _ (_, Nothing)) = return ()
-stampAndSend targetMap bus local nudge cconf cref ss (Targeted ts (t, Just msg)) = do
- let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)
- let targs = catMaybes $ map (`Map.lookup` targetMap) ts
- let getBusTargets (Target _ path _ (Just addr)) = [(path, addr)]
- getBusTargets (Target _ _ _ Nothing) = []
- let addrs = if bus then concatMap getBusTargets targs else map (\x -> (tOSCPath x, tAddress x)) targs
-
- on <- Clock.timeAtBeat cconf ss onBeat
- onOSC <- Clock.linkToOscTime cref on
-
- mapM_ (\(path, addr) -> sendMessage addr local defaultLatency nudge (onOSC, msg path)) addrs
-
-sendMessage :: RemoteAddress -> O.Udp -> Double -> Double -> (Double, O.Message) -> IO ()
-sendMessage remote local latency extraLatency (time, m) = sendBndl $ O.Bundle timeWithLatency [m]
- where
- timeWithLatency = time - latency + extraLatency
- sendBndl bndl = O.sendTo local (O.Packet_Bundle bndl) remote
-
--------------------------------------------------
-------------------- utilities -------------------
--------------------------------------------------
-
-updateState :: MVar ExpressionMap -> [ExpressionMap] -> IO ()
-updateState _ [] = return ()
-updateState stmv (st : _) = modifyMVar_ stmv (const $ return st)
diff --git a/src/zwirn-lang/Zwirn/Stream/Target.hs b/src/zwirn-lang/Zwirn/Stream/Target.hs
deleted file mode 100644
--- a/src/zwirn-lang/Zwirn/Stream/Target.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-
-module Zwirn.Stream.Target where
-
-import qualified Data.Map as Map
-import Data.Text (Text)
-import qualified Network.Socket as N
-
-type RemoteAddress = N.SockAddr
-
-type TargetName = Text
-
-data Targeted a
- = Targeted
- { targets :: [TargetName],
- tValue :: a
- }
- deriving (Functor)
-
-data Target = Target
- { tOSCPath :: Text,
- tBusOSCPath :: Text,
- tAddress :: RemoteAddress,
- tBusAddress :: Maybe RemoteAddress
- }
-
-type TargetMap = Map.Map TargetName Target
-
-data TargetConfig = TargetConfig
- { targetConfigName :: Text,
- targetConfigOSCPath :: Text,
- targetConfigBusOSCPath :: Text,
- targetConfigAddress :: String,
- targetConfigPort :: Int,
- targetConfigBusPort :: Maybe Int
- }
-
-resolve :: String -> Int -> IO N.AddrInfo
-resolve host port = do
- let hints = N.defaultHints {N.addrSocketType = N.Stream}
- addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port)
- return addr
-
-getTarget :: TargetConfig -> IO (Text, Target)
-getTarget config = do
- let target_address = targetConfigAddress config
- target_port = targetConfigPort config
- target_bus_port = targetConfigBusPort config
- remote <- resolve target_address target_port
- remoteBus <- mapM (resolve target_address) target_bus_port
- return (targetConfigName config, Target (targetConfigOSCPath config) (targetConfigBusOSCPath config) (N.addrAddress remote) (N.addrAddress <$> remoteBus))
-
-getTargetMap :: [TargetConfig] -> IO TargetMap
-getTargetMap confs = Map.fromList <$> mapM getTarget confs
diff --git a/src/zwirn-lang/Zwirn/Stream/Types.hs b/src/zwirn-lang/Zwirn/Stream/Types.hs
deleted file mode 100644
--- a/src/zwirn-lang/Zwirn/Stream/Types.hs
+++ /dev/null
@@ -1,52 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Zwirn.Stream.Types where
-
-import Control.Concurrent.MVar (MVar)
-import qualified Data.Map as Map
-import Data.Text (Text)
-import GHC.Generics (Generic)
-import qualified Sound.Osc.Transport.Fd.Udp as O
-import Sound.Tidal.Clock
-import Zwirn.Language.Evaluate.Expression
-import Zwirn.Stream.Target
-
-data PlayState
- = Normal
- | Solo
- | Mute
- deriving (Eq, Show)
-
-data Identifier
- = TextID Text
- | NumID Int
- deriving (Eq, Show, Ord)
-
-type PlayMap =
- Map.Map Identifier (Targeted (PlayState, Zwirn Expression, Maybe (Zwirn (Zwirn Expression -> Zwirn Expression))))
-
-type ActionMap = Map.Map Identifier (Zwirn Expression)
-
-type BusMap = Map.Map Int (Targeted (Zwirn Expression))
-
-data StreamConfig = StreamConfig
- { streamConfigTargets :: [TargetConfig],
- streamConfigDefaultTarget :: Text,
- streamConfigLocalPort :: Int,
- streamConfigPrecision :: Rational,
- streamConfigClock :: ClockConfig
- }
- deriving (Generic)
-
-data Stream = Stream
- { sPlayMap :: MVar PlayMap,
- sActionMap :: MVar ActionMap,
- sBusMap :: MVar BusMap,
- sState :: MVar ExpressionMap,
- sBusses :: MVar [Int],
- sTargetMap :: TargetMap,
- sDefaultTarget :: Text,
- sLocal :: O.Udp,
- sClockRef :: ClockRef,
- sConfig :: StreamConfig
- }
diff --git a/src/zwirn-lang/Zwirn/Stream/UI.hs b/src/zwirn-lang/Zwirn/Stream/UI.hs
deleted file mode 100644
--- a/src/zwirn-lang/Zwirn/Stream/UI.hs
+++ /dev/null
@@ -1,194 +0,0 @@
-module Zwirn.Stream.UI where
-
-import Control.Concurrent (readMVar)
-import Control.Concurrent.MVar (modifyMVar_, newMVar)
-import qualified Data.Map as Map
-import Data.Text (pack)
-import qualified Data.Text as T
-import qualified Sound.Osc.Transport.Fd.Udp as O
-import Sound.Tidal.Clock
-import qualified Sound.Tidal.Clock as Clock
-import Zwirn.Core.Lib.Core (zipApply)
-import Zwirn.Core.Lib.Modulate (shift, slow)
-import Zwirn.Core.Lib.Number (firstCyclesThen)
-import Zwirn.Core.Lib.Structure (segment)
-import qualified Zwirn.Core.Time as Zwirn
-import Zwirn.Core.Types (silence, toList, unzwirn, value)
-import Zwirn.Language.Evaluate.Expression
-import Zwirn.Stream.Process
-import Zwirn.Stream.Target
-import Zwirn.Stream.Types
-
-streamDefaultBPM :: Double
-streamDefaultBPM = 138
-
-streamReplace :: Stream -> Targeted Identifier -> Zwirn Expression -> IO ()
-streamReplace _ (Targeted _ (TextID "_all")) _ = return ()
-streamReplace _ (Targeted _ (TextID "_none")) _ = return ()
-streamReplace str (Targeted ts key) p = modifyMVar_ (sPlayMap str) (return . Map.alter alterFunc key)
- where
- newTargs = if null ts then [sDefaultTarget str] else ts
- filterTargs = filter (\t -> t `elem` Map.keys (sTargetMap str)) newTargs
- alterFunc Nothing = if null filterTargs then Nothing else Just (Targeted filterTargs (Normal, p, Nothing))
- alterFunc (Just (Targeted _ (_, _, fx))) = if null filterTargs then Nothing else Just (Targeted filterTargs (Normal, p, fx))
-
-streamReplaceBus :: Stream -> Targeted Int -> Zwirn Expression -> IO ()
-streamReplaceBus str (Targeted ts key) p = modifyMVar_ (sBusMap str) (return . Map.insert key (Targeted filterTargs $ segment (pure 128) p))
- where
- newTargs = if null ts then [sDefaultTarget str] else ts
- filterTargs = filter (\t -> t `elem` Map.keys (sTargetMap str)) newTargs
-
-streamReplaceAction :: Stream -> Identifier -> Zwirn Expression -> IO ()
-streamReplaceAction _ (TextID "_all") _ = return ()
-streamReplaceAction _ (TextID "_none") _ = return ()
-streamReplaceAction str key p = modifyMVar_ (sActionMap str) (return . Map.insert key p)
-
-streamHush :: Stream -> IO ()
-streamHush str = do
- modifyMVar_ (sPlayMap str) (return . const Map.empty)
- modifyMVar_ (sActionMap str) (return . const Map.empty)
- modifyMVar_ (sBusMap str) (return . const Map.empty)
-
-streamSet :: Stream -> T.Text -> Expression -> IO ()
-streamSet str x ex = modifyMVar_ (sState str) (return . Map.insert x ex)
-
-streamSetFx :: Stream -> Identifier -> Zwirn (Zwirn Expression -> Zwirn Expression) -> IO ()
-streamSetFx str (TextID "_all") fx = modifyMVar_ (sPlayMap str) (return . fmap (fmap (\(st, p, _) -> (st, p, Just fx))))
-streamSetFx str (TextID "_none") _ = modifyMVar_ (sPlayMap str) (return . fmap (fmap (\(st, p, _) -> (st, p, Nothing))))
-streamSetFx str key fx = modifyMVar_ (sPlayMap str) (return . Map.update (\(Targeted ts (st, p, _)) -> Just $ Targeted ts (st, p, Just fx)) key)
-
-streamGet :: Stream -> T.Text -> IO Expression
-streamGet str key = do
- sm <- readMVar (sState str)
- return $ Map.findWithDefault (EZwirn silence) key sm
-
-streamToggle :: Stream -> Identifier -> IO ()
-streamToggle str key = case key of
- (TextID "_all") -> modifyMVar_ (sPlayMap str) (return . fmap (fmap toggle))
- _ -> modifyMVar_ (sPlayMap str) (return . Map.adjust (fmap toggle) key)
- where
- toggle (Mute, p, fx) = (Normal, p, fx)
- toggle (_, p, fx) = (Mute, p, fx)
-
-streamMute :: Stream -> Identifier -> IO ()
-streamMute str key = case key of
- TextID "_all" -> modifyMVar_ (sPlayMap str) (return . fmap (fmap toggle))
- TextID "_none" -> streamUnmute str (TextID "_all")
- _ -> modifyMVar_ (sPlayMap str) (return . Map.adjust (fmap toggle) key)
- where
- toggle (Normal, p, fx) = (Mute, p, fx)
- toggle (Solo, p, fx) = (Mute, p, fx)
- toggle x = x
-
-streamUnmute :: Stream -> Identifier -> IO ()
-streamUnmute str key = case key of
- TextID "_all" -> modifyMVar_ (sPlayMap str) (return . fmap (fmap toggle))
- TextID "_none" -> streamMute str (TextID "_all")
- _ -> modifyMVar_ (sPlayMap str) (return . Map.adjust (fmap toggle) key)
- where
- toggle (Mute, p, fx) = (Normal, p, fx)
- toggle x = x
-
-streamSolo :: Stream -> Identifier -> IO ()
-streamSolo str key = case key of
- (TextID "_all") -> modifyMVar_ (sPlayMap str) (return . fmap (fmap toggle))
- (TextID "_none") -> streamUnsolo str (TextID "_all")
- _ -> modifyMVar_ (sPlayMap str) (return . Map.adjust (fmap toggle) key)
- where
- toggle (Normal, p, fx) = (Solo, p, fx)
- toggle (Mute, p, fx) = (Solo, p, fx)
- toggle x = x
-
-streamUnsolo :: Stream -> Identifier -> IO ()
-streamUnsolo str key = case key of
- (TextID "_all") -> modifyMVar_ (sPlayMap str) (return . fmap (fmap toggle))
- (TextID "_none") -> streamSolo str (TextID "_all")
- _ -> modifyMVar_ (sPlayMap str) (return . Map.adjust (fmap toggle) key)
- where
- toggle (Solo, p, fx) = (Normal, p, fx)
- toggle x = x
-
-streamToggleSolo :: Stream -> Identifier -> IO ()
-streamToggleSolo str key = case key of
- (TextID "_all") -> modifyMVar_ (sPlayMap str) (return . fmap (fmap toggle))
- _ -> modifyMVar_ (sPlayMap str) (return . Map.adjust (fmap toggle) key)
- where
- toggle (Solo, p, fx) = (Normal, p, fx)
- toggle (_, p, fx) = (Solo, p, fx)
-
-streamSetCPS :: Stream -> Time -> IO ()
-streamSetCPS str c = streamSetBPM str (c * toRational (cBeatsPerCycle (streamConfigClock $ sConfig str) * 60))
-
--- | set the bpm in the clock
-streamSetBPM :: Stream -> Time -> IO ()
-streamSetBPM s = Clock.setBPM (sClockRef s)
-
-streamGetBPM :: Stream -> IO Double
-streamGetBPM str = realToFrac <$> Clock.getBPM (sClockRef str)
-
-streamResetCycles :: Stream -> IO ()
-streamResetCycles s = streamSetCycle s 0
-
-streamSetCycle :: Stream -> Time -> IO ()
-streamSetCycle s = Clock.setClock (sClockRef s)
-
-streamEnableLink :: Stream -> IO ()
-streamEnableLink s = Clock.enableLink (sClockRef s)
-
-streamDisableLink :: Stream -> IO ()
-streamDisableLink s = Clock.disableLink (sClockRef s)
-
-streamGetNow :: Stream -> IO Time
-streamGetNow s = Clock.getCycleTime (streamConfigClock $ sConfig s) (sClockRef s)
-
-streamFirst :: Stream -> Zwirn Expression -> IO ()
-streamFirst str = streamFirstTarget str (sDefaultTarget str)
-
-streamFirstTarget :: Stream -> TargetName -> Zwirn Expression -> IO ()
-streamFirstTarget str targ z = do
- dummy <- newMVar $ Map.singleton (TextID $ pack "_streamOnceDummy_") (Targeted [targ] (Normal, z, Nothing))
- Clock.clockOnce (tickAction dummy (sActionMap str) (sBusMap str) (sState str) (sBusses str) (sTargetMap str) (sLocal str) (streamConfigPrecision $ sConfig str)) (streamConfigClock $ sConfig str) (sClockRef str)
-
-startStream :: StreamConfig -> IO Stream
-startStream config = do
- let targetConfigs = streamConfigTargets config
- conf = (streamConfigClock config) {cFrameTimespan = 10 * realToFrac (streamConfigPrecision config)}
- targetMap <- getTargetMap targetConfigs
- local <- O.udp_server (streamConfigLocalPort config)
-
- zMV <- newMVar Map.empty
- stMV <- newMVar Map.empty
- busMapMV <- newMVar Map.empty
- actionMapMV <- newMVar Map.empty
- bussesMV <- newMVar []
-
- cref <- clocked conf (tickAction zMV actionMapMV busMapMV stMV bussesMV targetMap local (streamConfigPrecision config))
- let str = Stream zMV actionMapMV busMapMV stMV bussesMV targetMap "superdirt" local cref config
-
- -- set the default bpm
- streamSetBPM str (realToFrac streamDefaultBPM)
- return str
-
-evalAction :: Stream -> Zwirn Expression -> IO ()
-evalAction str z = do
- st <- readMVar (sState str)
- let exps = toList $ unzwirn z 0 st
- sts = map snd exps
- exs = map (value . fst) exps
-
- updateState (sState str) sts
- mapM_ evalActionExp exs
- where
- evalActionExp (EAction i) = i
- evalActionExp _ = return ()
-
-transition :: Stream -> Identifier -> (Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> IO ()
-transition str key mapper = do
- now <- realToFrac <$> streamGetNow str
- modifyMVar_ (sPlayMap str) (return . Map.update (\(Targeted ts (ps, ex, fx)) -> Just $ Targeted ts (ps, mapper (pure now) `zipApply` ex, fx)) key)
-
-transition' :: Stream -> Identifier -> Zwirn Zwirn.Time -> Zwirn Expression -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> IO ()
-transition' str key dur def sig mapper = do
- now <- realToFrac <$> streamGetNow str
- let shifted = shift (pure now) $ firstCyclesThen dur def (slow dur sig)
- modifyMVar_ (sPlayMap str) (return . Map.update (\(Targeted ts (ps, ex, fx)) -> Just $ Targeted ts (ps, mapper `zipApply` ex `zipApply` shifted, fx)) key)
diff --git a/src/zwirn-stream/Zwirn/Stream/Env.hs b/src/zwirn-stream/Zwirn/Stream/Env.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/Env.hs
@@ -0,0 +1,133 @@
+module Zwirn.Stream.Env where
+
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad (void)
+import Data.Fixed (mod')
+import qualified Data.Map as Map
+import Data.Text
+import Sound.Tidal.Clock (getCPS, getCycleTime)
+import Zwirn.Core.Time (Time)
+import Zwirn.Language.Builtin.Internal
+import Zwirn.Language.Builtin.Prelude (builtinEnvironmentWithPlayEnv, instances)
+import Zwirn.Language.Environment
+import Zwirn.Language.Evaluate (Zwirn, toID)
+import Zwirn.Language.Evaluate.Convert (ToExpression (..))
+import Zwirn.Language.Evaluate.Expression (Expression)
+import Zwirn.Language.Play
+import Zwirn.Stream.Types (Stream (..), StreamConfig (..))
+import Zwirn.Stream.UI as Stream
+
+builtinEnvironmentWithStream :: Stream -> InterpreterEnv
+builtinEnvironmentWithStream str = IEnv (Map.unions [std, streamFunctions str]) instances
+ where
+ (IEnv std _) = builtinEnvironmentWithPlayEnv (playEnvFromStream str)
+
+playEnvFromStream :: Stream -> PlayEnv
+playEnvFromStream str = (PlayEnv {playMap = sPlayMap str, actionMap = sActionMap str, busMap = sBusMap str})
+
+once :: Stream -> Zwirn Expression -> Zwirn (IO ())
+once str iz = pure (streamFirst str iz)
+
+tonce :: Stream -> Zwirn Text -> Zwirn Expression -> Zwirn (IO ())
+tonce str tz iz = flip (streamFirstTarget str) iz <$> tz
+
+bpm :: Stream -> Zwirn Double -> Zwirn (IO ())
+bpm str iz = streamSetBPM str . realToFrac <$> iz
+
+cps :: Stream -> Zwirn Double -> Zwirn (IO ())
+cps str iz = streamSetCPS str . realToFrac <$> iz
+
+setcycle :: Stream -> Zwirn Double -> Zwirn (IO ())
+setcycle str iz = streamSetCycle str . realToFrac <$> iz
+
+resetcycles :: Stream -> Zwirn (IO ())
+resetcycles str = pure $ streamResetCycles str
+
+enablelink :: Stream -> Zwirn (IO ())
+enablelink str = pure $ streamEnableLink str
+
+disablelink :: Stream -> Zwirn (IO ())
+disablelink str = pure $ streamDisableLink str
+
+execIn :: Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
+execIn dz acz = execInSecs_ <$> dz <*> acz
+ where
+ execInSecs_ :: Double -> IO () -> IO ()
+ execInSecs_ d ac = void $ forkIO $ threadDelay (floor $ d * 1000000) >> ac
+
+execIn' :: Stream -> Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
+execIn' str dz acz = execInCycs_ <$> dz <*> acz
+ where
+ execInCycs_ :: Double -> IO () -> IO ()
+ execInCycs_ d ac = do
+ xcps <- getCPS (streamConfigClock $ sConfig str) (sClockRef str)
+ void $ forkIO $ threadDelay (floor $ d * realToFrac xcps * 1000000) >> ac
+
+execMod :: Stream -> Zwirn Double -> Zwirn (IO ()) -> Zwirn (IO ())
+execMod str dz acz = execMod_ <$> dz <*> acz
+ where
+ execMod_ :: Double -> IO () -> IO ()
+ execMod_ d ac = do
+ xcps <- getCPS (streamConfigClock $ sConfig str) (sClockRef str)
+ now <- getCycleTime (streamConfigClock $ sConfig str) (sClockRef str)
+ let del = d - mod' (realToFrac now) d
+ void $ forkIO $ threadDelay (floor $ del * realToFrac xcps * 1000000) >> ac
+
+transition :: Stream -> Zwirn Expression -> Zwirn (Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn (IO ())
+transition str kz = liftA2 (Stream.transition str) (toID <$> kz)
+
+transition' :: Stream -> Zwirn Expression -> Zwirn Time -> Zwirn Expression -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> Zwirn (IO ())
+transition' str kz dur def sig fun = (\k -> Stream.transition' str k dur def sig fun) . toID <$> kz
+
+streamFunctions :: Stream -> Map.Map Text AnnotatedExpression
+streamFunctions str =
+ Map.unions
+ [ "once"
+ === toExp (once str)
+ <:: "Map -> Action"
+ --| "play one cycle of the given zwirn",
+ "tonce"
+ === toExp (tonce str)
+ <:: "Text -> Map -> Action"
+ --| "play one cycle of the given zwirn on the given target",
+ "bpm"
+ === toExp (bpm str)
+ <:: "Number -> Action"
+ --| "set the current bpm (beats per minute)",
+ "cps"
+ === toExp (cps str)
+ <:: "Number -> Action"
+ --| "set the current cps (cycles per second)",
+ "resetcycles"
+ === toExp (resetcycles str)
+ <:: "Action"
+ --| "resets the cycle count to 0",
+ "setcycle"
+ === toExp (setcycle str)
+ <:: "Number -> Action"
+ --| "set the current cycle to specific point in time",
+ "disablelink"
+ === toExp (disablelink str)
+ <:: "Action"
+ --| "disable ableton link",
+ "enablelink"
+ === toExp (enablelink str)
+ <:: "Action"
+ --| "enable ableton link",
+ "in"
+ === toExp (execIn' str)
+ <:: "Number -> Action -> Action"
+ --| "start an action in a given amount of seconds",
+ "inMod"
+ === toExp (execMod str)
+ <:: "Number -> Action -> Action"
+ --| "start an action in a given amount of seconds",
+ "transitionmap"
+ === toExp (Zwirn.Stream.Env.transition str)
+ <:: "Id a => a -> (Number -> Map -> Map) -> Action"
+ --| "",
+ "transition"
+ === toExp (Zwirn.Stream.Env.transition' str)
+ <:: "Id a => a -> Number -> b -> b -> (Map -> b -> Map) -> Action"
+ --| ""
+ ]
diff --git a/src/zwirn-stream/Zwirn/Stream/Handshake.hs b/src/zwirn-stream/Zwirn/Stream/Handshake.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/Handshake.hs
@@ -0,0 +1,29 @@
+module Zwirn.Stream.Handshake where
+
+import Control.Concurrent.MVar (MVar, swapMVar)
+import Control.Monad (void)
+import Data.Maybe (catMaybes, isJust)
+import qualified Sound.Osc as O
+import qualified Sound.Osc.Transport.Fd.Udp as O
+import Zwirn.Stream.Target
+
+-- handshake is in the responsibility of a specific listener implementation
+-- these functions can be used to implement it
+
+sendHandshake :: O.Udp -> RemoteAddress -> IO ()
+sendHandshake udp = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" [])
+
+isHandshakeMsg :: O.Message -> Bool
+isHandshakeMsg (O.Message "/dirt/hello" _) = True
+isHandshakeMsg (O.Message "/dirt/handshake/reply" _) = True
+isHandshakeMsg _ = False
+
+actOnHandshake :: O.Message -> O.Udp -> RemoteAddress -> MVar [Int] -> IO ()
+actOnHandshake (O.Message "/dirt/hello" _) udp remote _ = sendHandshake udp remote
+actOnHandshake (O.Message "/dirt/handshake/reply" xs) _ _ bussesMV = void $ swapMVar bussesMV $ bufferIndices xs
+ where
+ bufferIndices [] = []
+ bufferIndices (x : xs')
+ | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
+ | otherwise = bufferIndices xs'
+actOnHandshake _ _ _ _ = return ()
diff --git a/src/zwirn-stream/Zwirn/Stream/Listen.hs b/src/zwirn-stream/Zwirn/Stream/Listen.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/Listen.hs
@@ -0,0 +1,48 @@
+module Zwirn.Stream.Listen where
+
+import Data.Bifunctor (first)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import qualified Network.Socket as N
+import Sound.Osc as O
+import Sound.Osc.Transport.Fd.Udp as O
+import Zwirn.Language.Evaluate (Expression (..))
+import Zwirn.Stream.Handshake
+import Zwirn.Stream.Types (Stream (..))
+import Zwirn.Stream.UI
+
+type RemoteAddress = N.SockAddr
+
+listen :: Stream -> IO ()
+listen str = recvMessageFrom (sLocal str) >>= act str >> listen str
+
+recvMessageFrom :: O.Udp -> IO (Maybe Message, RemoteAddress)
+recvMessageFrom loc = fmap (first packet_to_message) (recvFrom loc)
+
+act :: Stream -> (Maybe O.Message, RemoteAddress) -> IO ()
+act str (Just (Message "/ping" []), remote) = replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Double val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Float val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ realToFrac val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Int32 val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ fromIntegral val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Int64 val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ fromIntegral val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, AsciiString val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ EText $ toUTF8 val) >> replyOk (sLocal str) remote
+act str (Just m, remote) =
+ if isHandshakeMsg m
+ then actOnHandshake m (sLocal str) remote (sBusses str)
+ else replyError (sLocal str) remote ("Unhandeled Message: " ++ show m)
+act _ _ = return ()
+
+reply :: O.Udp -> RemoteAddress -> O.Packet -> IO ()
+reply loc remote msg = O.sendTo loc msg remote
+
+replyOk :: O.Udp -> RemoteAddress -> IO ()
+replyOk loc = flip (reply loc) (O.p_message "/ok" [])
+
+replyError :: O.Udp -> RemoteAddress -> String -> IO ()
+replyError loc remote err = reply loc remote (O.p_message "/error" [utf8String err])
+
+utf8String :: String -> O.Datum
+utf8String s = O.AsciiString $ encodeUtf8 $ T.pack s
+
+toUTF8 :: O.Ascii -> T.Text
+toUTF8 = decodeUtf8
diff --git a/src/zwirn-stream/Zwirn/Stream/Process.hs b/src/zwirn-stream/Zwirn/Stream/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/Process.hs
@@ -0,0 +1,169 @@
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use mapMaybe" #-}
+
+module Zwirn.Stream.Process where
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.MVar (MVar, modifyMVar_, readMVar)
+import Data.Bifunctor (first)
+import Data.List (mapAccumL)
+import qualified Data.Map as Map
+import Data.Maybe (catMaybes)
+import qualified Data.Text as T
+import Data.Tuple (swap)
+import qualified Sound.Osc as O
+import qualified Sound.Osc.Transport.Fd.Udp as O
+import Sound.Tidal.Clock
+import qualified Sound.Tidal.Clock as Clock
+import Sound.Tidal.Link
+import Zwirn.Core.Query
+import qualified Zwirn.Core.Time as Z
+import Zwirn.Language.Evaluate (toExp)
+import Zwirn.Language.Evaluate.Expression
+import Zwirn.Language.Play (ActionMap, BusMap, PlayMap, Targeted (..), resolvePlayMap)
+import Zwirn.Stream.Target
+
+tickAction ::
+ MVar PlayMap -> -- maps from channels to expressions
+ MVar ActionMap -> -- maps from channels to expressions
+ MVar BusMap -> -- maps from busses to expressions
+ MVar ExpressionMap -> -- state map
+ MVar [Int] -> -- bus mapping
+ TargetMap -> -- targets
+ O.Udp -> -- local address
+ Time -> -- precision
+ (Time, Time) -> -- arc of the current tick
+ Double -> -- nudge
+ ClockConfig -> -- configuration of the clock
+ ClockRef -> -- reference to the clock
+ (SessionState, SessionState) ->
+ IO ()
+tickAction zMV actionMapMV busMapMV stMV bussesMV targetMap local prec (star, end) nudge cconf cref (ss, _) = do
+ cps <- Clock.getCPS cconf cref
+ vs <- processPlayMap prec (star, end) cps zMV stMV
+ bs <- processBusMap prec (star, end) busMapMV stMV bussesMV
+ processActionMap prec (star, end) cps actionMapMV stMV
+ mapM_ (stampAndSend targetMap False local nudge cconf cref ss) vs
+ mapM_ (stampAndSend targetMap True local nudge cconf cref ss . (\(Targeted ts (t, m)) -> Targeted ts (t, Just m))) bs
+ updateTempo cref stMV
+
+processPlayMap :: Time -> (Time, Time) -> Time -> MVar PlayMap -> MVar ExpressionMap -> IO [Targeted (Z.Time, Maybe (T.Text -> O.Message))]
+processPlayMap prec (star, end) cps zMV stMV = do
+ pm <- readMVar zMV
+ let ps = resolvePlayMap pm
+ st <- readMVar stMV
+
+ let (enst, vs) = mapAccumL (\ !s (Targeted ts p) -> swap $ first (Targeted ts) $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
+
+ modifyMVar_ stMV (const $ return enst)
+ let func (t, ex) = expressionToMessage (fromIntegral (floor t :: Int)) (realToFrac cps) ex >>= \m -> return (t, m)
+
+ concat <$> mapM (\targ -> (\(Targeted ts xs) -> mapM (fmap (Targeted ts) . func) xs) targ) vs
+
+processActionMap :: Time -> (Time, Time) -> Time -> MVar ActionMap -> MVar ExpressionMap -> IO ()
+processActionMap prec (star, end) cps zMV stMV = do
+ pm <- readMVar zMV
+ let ps = Map.elems pm
+ st <- readMVar stMV
+
+ let (_, vs) = mapAccumL (\ !s p -> swap $ findAllValuesWithTimeStatePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) s p) st ps
+
+ mapM_ (\(t, ex) -> expressionToMessage (fromIntegral (floor t :: Int)) (realToFrac cps) ex >>= \m -> return (t, m)) (concat vs)
+
+processBusMap :: Time -> (Time, Time) -> MVar BusMap -> MVar ExpressionMap -> MVar [Int] -> IO [Targeted (Z.Time, T.Text -> O.Message)]
+processBusMap prec (star, end) busMV stMV bussesMV = do
+ bm <- readMVar busMV
+ let bs = Map.toList bm
+ busses <- readMVar bussesMV
+ st <- readMVar stMV
+
+ concat <$> mapM (\(i, Targeted ts x) -> map (Targeted ts) <$> busToMessage prec (star, end) busses st (i, x)) bs
+
+busToMessage :: Time -> (Time, Time) -> [Int] -> ExpressionMap -> (Int, Zwirn Expression) -> IO [(Z.Time, T.Text -> O.Message)]
+busToMessage prec (star, end) busses st (i, p) = do
+ let vs = findAllValuesWithTimePrec (Z.Time prec 0) (Z.Time (align prec star) 1, Z.Time (align prec end) 1) st p
+
+ mapM (\(t, ex) -> busExpressionToMessage (toBus busses i) ex >>= \m -> return (t, m)) vs
+
+toBus :: [Int] -> Int -> Int
+toBus [] i = i
+toBus xs i = xs !! (i `mod` length xs)
+
+align :: Time -> Time -> Time
+align prec t = fromIntegral (floor $ t / prec :: Int) * prec
+
+----------------------------------------------------------
+-------------- expressions --> osc messages --------------
+----------------------------------------------------------
+
+expressionToMessage :: Double -> Double -> Expression -> IO (Maybe (T.Text -> O.Message))
+expressionToMessage cyc cps ex = do
+ os <- expressionToOSC ex
+ let additionalData = [O.string "cps", O.float cps, O.string "cycle", O.float cyc]
+ if null os
+ then return Nothing
+ else return $ Just $ \pat -> O.message (T.unpack pat) (additionalData ++ os)
+
+busExpressionToMessage :: Int -> Expression -> IO (T.Text -> O.Message)
+busExpressionToMessage bus ex = do
+ os <- expressionToOSC ex
+ return $ \path -> O.message (T.unpack path) (O.int32 bus : os)
+
+expressionToOSC :: Expression -> IO [O.Datum]
+expressionToOSC (ENum n) = return [O.float n]
+expressionToOSC (EText n) = return [O.string $ T.unpack n]
+expressionToOSC (EMap m) = concat <$> mapM (\(k, v) -> expressionToOSC v >>= \xs -> return $ O.string (T.unpack k) : xs) (Map.toList m)
+expressionToOSC (EAction a) = forkIO a >> return []
+expressionToOSC _ = return []
+
+----------------------------------------------
+-------------- sending messages --------------
+----------------------------------------------
+
+defaultLatency :: Double
+defaultLatency = 0.2
+
+stampAndSend :: TargetMap -> Bool -> O.Udp -> Double -> ClockConfig -> ClockRef -> SessionState -> Targeted (Z.Time, Maybe (T.Text -> O.Message)) -> IO ()
+stampAndSend _ _ _ _ _ _ _ (Targeted _ (_, Nothing)) = return ()
+stampAndSend targetMap bus local nudge cconf cref ss (Targeted ts (t, Just msg)) = do
+ let onBeat = Clock.cyclesToBeat cconf ((\(Z.Time r _) -> fromRational r :: Double) t)
+ let targs = if null ts then Map.elems targetMap else catMaybes $ map (`Map.lookup` targetMap) ts
+ let getBusTargets (Target _ path _ (Just addr)) = [(path, addr)]
+ getBusTargets (Target _ _ _ Nothing) = []
+ let addrs = if bus then concatMap getBusTargets targs else map (\x -> (tOSCPath x, tAddress x)) targs
+
+ on <- Clock.timeAtBeat cconf ss onBeat
+ onOSC <- Clock.linkToOscTime cref on
+
+ mapM_ (\(path, addr) -> sendMessage addr local defaultLatency nudge (onOSC, msg path)) addrs
+
+sendMessage :: RemoteAddress -> O.Udp -> Double -> Double -> (Double, O.Message) -> IO ()
+sendMessage remote local latency extraLatency (time, m) = sendBndl $ O.Bundle timeWithLatency [m]
+ where
+ timeWithLatency = time - latency + extraLatency
+ sendBndl bndl = O.sendTo local (O.Packet_Bundle bndl) remote
+
+updateTempo :: ClockRef -> MVar ExpressionMap -> IO ()
+updateTempo cref stMV = do
+ bpm <- realToFrac <$> Clock.getBPM cref
+ modifyMVar_ stMV (return . Map.insert "_tempo" (toExp (pure bpm :: Zwirn Double)))
+
+-- tickActionOnce only proccesses the playmap
+tickActionOnce ::
+ MVar PlayMap ->
+ MVar ExpressionMap -> -- state map
+ TargetMap -> -- targets
+ O.Udp -> -- local address
+ Time -> -- precision
+ (Time, Time) -> -- arc of the current tick
+ Double -> -- nudge
+ ClockConfig -> -- configuration of the clock
+ ClockRef -> -- reference to the clock
+ (SessionState, SessionState) ->
+ IO ()
+tickActionOnce zMV stMV targetMap local prec (star, end) nudge cconf cref (ss, _) = do
+ cps <- Clock.getCPS cconf cref
+ vs <- processPlayMap prec (star, end) cps zMV stMV
+ mapM_ (stampAndSend targetMap False local nudge cconf cref ss) vs
diff --git a/src/zwirn-stream/Zwirn/Stream/Target.hs b/src/zwirn-stream/Zwirn/Stream/Target.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/Target.hs
@@ -0,0 +1,44 @@
+module Zwirn.Stream.Target where
+
+import qualified Data.Map as Map
+import Data.Text (Text)
+import qualified Network.Socket as N
+import Zwirn.Language.Play (TargetName)
+
+type RemoteAddress = N.SockAddr
+
+data Target = Target
+ { tOSCPath :: Text,
+ tBusOSCPath :: Text,
+ tAddress :: RemoteAddress,
+ tBusAddress :: Maybe RemoteAddress
+ }
+
+type TargetMap = Map.Map TargetName Target
+
+data TargetConfig = TargetConfig
+ { targetConfigName :: Text,
+ targetConfigOSCPath :: Text,
+ targetConfigBusOSCPath :: Text,
+ targetConfigAddress :: String,
+ targetConfigPort :: Int,
+ targetConfigBusPort :: Maybe Int
+ }
+
+resolve :: String -> Int -> IO N.AddrInfo
+resolve host port = do
+ let hints = N.defaultHints {N.addrSocketType = N.Stream}
+ addr : _ <- N.getAddrInfo (Just hints) (Just host) (Just $ show port)
+ return addr
+
+getTarget :: TargetConfig -> IO (Text, Target)
+getTarget config = do
+ let target_address = targetConfigAddress config
+ target_port = targetConfigPort config
+ target_bus_port = targetConfigBusPort config
+ remote <- resolve target_address target_port
+ remoteBus <- mapM (resolve target_address) target_bus_port
+ return (targetConfigName config, Target (targetConfigOSCPath config) (targetConfigBusOSCPath config) (N.addrAddress remote) (N.addrAddress <$> remoteBus))
+
+getTargetMap :: [TargetConfig] -> IO TargetMap
+getTargetMap confs = Map.fromList <$> mapM getTarget confs
diff --git a/src/zwirn-stream/Zwirn/Stream/Types.hs b/src/zwirn-stream/Zwirn/Stream/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/Types.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Zwirn.Stream.Types where
+
+import Control.Concurrent.MVar (MVar)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import qualified Sound.Osc.Transport.Fd.Udp as O
+import Sound.Tidal.Clock
+import Zwirn.Language.Evaluate.Expression
+import Zwirn.Language.Play (ActionMap, BusMap, PlayMap)
+import Zwirn.Stream.Target
+
+data StreamConfig = StreamConfig
+ { streamConfigTargets :: [TargetConfig],
+ streamConfigDefaultTarget :: Text,
+ streamConfigLocalPort :: Int,
+ streamConfigPrecision :: Rational,
+ streamConfigClock :: ClockConfig
+ }
+ deriving (Generic)
+
+data Stream = Stream
+ { sPlayMap :: MVar PlayMap,
+ sActionMap :: MVar ActionMap,
+ sBusMap :: MVar BusMap,
+ sState :: MVar ExpressionMap,
+ sBusses :: MVar [Int],
+ sTargetMap :: TargetMap,
+ sDefaultTarget :: Text,
+ sLocal :: O.Udp,
+ sClockRef :: ClockRef,
+ sConfig :: StreamConfig
+ }
diff --git a/src/zwirn-stream/Zwirn/Stream/UI.hs b/src/zwirn-stream/Zwirn/Stream/UI.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-stream/Zwirn/Stream/UI.hs
@@ -0,0 +1,88 @@
+module Zwirn.Stream.UI where
+
+import Control.Concurrent.MVar (modifyMVar_, newMVar)
+import qualified Data.Map as Map
+import Data.Text (pack)
+import qualified Data.Text as T
+import qualified Sound.Osc.Transport.Fd.Udp as O
+import Sound.Tidal.Clock
+import qualified Sound.Tidal.Clock as Clock
+import Zwirn.Core.Lib.Core (zipApply)
+import Zwirn.Core.Lib.Modulate (shift, slow)
+import Zwirn.Core.Lib.Number (firstCyclesThen)
+import qualified Zwirn.Core.Time as Zwirn
+import Zwirn.Language.Evaluate.Expression
+import Zwirn.Language.Play (Identifier (..), PlayState (..), TargetName, Targeted (..))
+import Zwirn.Stream.Process
+import Zwirn.Stream.Target
+import Zwirn.Stream.Types
+
+streamDefaultBPM :: Double
+streamDefaultBPM = 138
+
+streamSet :: Stream -> T.Text -> Expression -> IO ()
+streamSet str x ex = modifyMVar_ (sState str) (return . Map.insert x ex)
+
+streamSetCPS :: Stream -> Time -> IO ()
+streamSetCPS str c = streamSetBPM str (c * toRational (clockBeatsPerCycle (streamConfigClock $ sConfig str) * 60))
+
+-- | set the bpm in the clock
+streamSetBPM :: Stream -> Time -> IO ()
+streamSetBPM s = Clock.setBPM (sClockRef s)
+
+streamGetBPM :: Stream -> IO Double
+streamGetBPM str = realToFrac <$> Clock.getBPM (sClockRef str)
+
+streamResetCycles :: Stream -> IO ()
+streamResetCycles s = streamSetCycle s 0
+
+streamSetCycle :: Stream -> Time -> IO ()
+streamSetCycle s = Clock.setClock (sClockRef s)
+
+streamEnableLink :: Stream -> IO ()
+streamEnableLink s = Clock.enableLink (sClockRef s)
+
+streamDisableLink :: Stream -> IO ()
+streamDisableLink s = Clock.disableLink (sClockRef s)
+
+streamGetNow :: Stream -> IO Time
+streamGetNow s = Clock.getCycleTime (streamConfigClock $ sConfig s) (sClockRef s)
+
+streamFirst :: Stream -> Zwirn Expression -> IO ()
+streamFirst str = streamFirstTarget str (sDefaultTarget str)
+
+streamFirstTarget :: Stream -> TargetName -> Zwirn Expression -> IO ()
+streamFirstTarget str targ z = do
+ dummy <- newMVar $ Map.singleton (TextID $ pack "_streamOnceDummy_") (Targeted [targ] (Normal, z, Nothing))
+ Clock.clockOnce (tickActionOnce dummy (sState str) (sTargetMap str) (sLocal str) (streamConfigPrecision $ sConfig str)) (streamConfigClock $ sConfig str) (sClockRef str)
+
+startStream :: StreamConfig -> IO Stream
+startStream config = do
+ let targetConfigs = streamConfigTargets config
+ conf = (streamConfigClock config) {clockFrameTimespan = 10 * realToFrac (streamConfigPrecision config)}
+ targetMap <- getTargetMap targetConfigs
+ local <- O.udp_server (streamConfigLocalPort config)
+
+ zMV <- newMVar Map.empty
+ stMV <- newMVar Map.empty
+ busMapMV <- newMVar Map.empty
+ actionMapMV <- newMVar Map.empty
+ bussesMV <- newMVar []
+
+ cref <- clocked conf (tickAction zMV actionMapMV busMapMV stMV bussesMV targetMap local (streamConfigPrecision config))
+ let str = Stream zMV actionMapMV busMapMV stMV bussesMV targetMap "superdirt" local cref config
+
+ -- set the default bpm
+ streamSetBPM str (realToFrac streamDefaultBPM)
+ return str
+
+transition :: Stream -> Identifier -> (Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> IO ()
+transition str key mapper = do
+ now <- realToFrac <$> streamGetNow str
+ modifyMVar_ (sPlayMap str) (return . Map.update (\(Targeted ts (ps, ex, fx)) -> Just $ Targeted ts (ps, mapper (pure now) `zipApply` ex, fx)) key)
+
+transition' :: Stream -> Identifier -> Zwirn Zwirn.Time -> Zwirn Expression -> Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression)) -> IO ()
+transition' str key dur def sig mapper = do
+ now <- realToFrac <$> streamGetNow str
+ let shifted = shift (pure now) $ firstCyclesThen dur def (slow dur sig)
+ modifyMVar_ (sPlayMap str) (return . Map.update (\(Targeted ts (ps, ex, fx)) -> Just $ Targeted ts (ps, mapper `zipApply` ex `zipApply` shifted, fx)) key)
diff --git a/test/zwirn-core/Main.hs b/test/zwirn-core/Main.hs
--- a/test/zwirn-core/Main.hs
+++ b/test/zwirn-core/Main.hs
@@ -8,10 +8,10 @@
import qualified Data.Ratio as R
import Test.Tasty
import Test.Tasty.HUnit
-import Zwirn.Core.Cord as Z
+import Zwirn.Core.Cord as Z hiding (length)
import Zwirn.Core.Core
import Zwirn.Core.Lib.Conditional
-import Zwirn.Core.Lib.Cord
+import Zwirn.Core.Lib.Cord hiding (length)
import Zwirn.Core.Lib.Core
import Zwirn.Core.Lib.Map
import Zwirn.Core.Lib.Modulate
@@ -64,6 +64,7 @@
instance State Tree () () where
beatsPerCycle = pure 8
+ cyclesPerSecond = pure 0.575
unitTests =
testGroup
diff --git a/zwirn.cabal b/zwirn.cabal
--- a/zwirn.cabal
+++ b/zwirn.cabal
@@ -1,9 +1,9 @@
cabal-version: 3.0
name: zwirn
-version: 0.2.2.1
+version: 0.2.3.1
synopsis: a live coding language for playing with nested functions of time
description: zwirn is a live coding language for playing with nested functions of time,
- which trigger the sending of osc-messages. it's syntax is inspired by TidalCycles'
+ whith additional discrete structure. it's syntax is inspired by TidalCycles'
mini-notation and its API for manipulating patterns.
license: GPL-3.0-only
license-file: LICENSE
@@ -14,6 +14,7 @@
build-type: Simple
extra-doc-files: README.md
tested-with: GHC == 9.12.2, GHC == 9.6.7
+extra-source-files: docs/**/*.md
source-repository head
type: git
@@ -35,7 +36,7 @@
common common-deps
build-depends: base >= 4.14 && < 4.22,
mtl >= 2.3 && < 2.4,
- containers >= 0.6.8 && < 0.8,
+ containers >= 0.7 && < 0.9,
text >= 2 && < 2.2,
@@ -64,7 +65,7 @@
build-depends: hmt >= 0.20 && < 0.21,
stm >= 2.5 && < 2.6,
random >= 1.2 && < 1.4,
- pure-noise >= 0.1.0.1 && < 0.2,
+ pure-noise >= 0.2 && < 0.3,
@@ -80,6 +81,7 @@
Zwirn.Language.Lexer
Zwirn.Language.Parser
Zwirn.Language.Compiler
+ Zwirn.Language.Play
Zwirn.Language.Rotate
Zwirn.Language.Simple
Zwirn.Language.Pretty
@@ -89,6 +91,7 @@
Zwirn.Language.Builtin.Internal
Zwirn.Language.Builtin.Prelude
Zwirn.Language.Builtin.Parameters
+ Zwirn.Language.Builtin.DouxParameters
Zwirn.Language.Environment
Zwirn.Language.Evaluate
Zwirn.Language.Evaluate.Convert
@@ -100,12 +103,6 @@
Zwirn.Language.LSP.Diagnostics
Zwirn.Language.LSP.InlayHints
Zwirn.Language
- Zwirn.Stream.Handshake
- Zwirn.Stream.Process
- Zwirn.Stream.Types
- Zwirn.Stream.UI
- Zwirn.Stream.Listen
- Zwirn.Stream.Target
other-modules: Paths_zwirn
autogen-modules: Paths_zwirn
@@ -115,20 +112,54 @@
prettyprinter >= 1.7 && < 1.8,
exceptions >= 0.10.9 && < 0.11,
filepath >= 1.5.4 && < 1.6,
- hosc >= 0.21.1 && < 0.22,
- network >= 3.2.7 && < 3.3,
- tidal-link >= 1.1 && < 1.2,
+
build-tool-depends: alex:alex, happy:happy
+library zwirn-stream
+ import: common-options,
+ common-deps
+ visibility: public
+ hs-source-dirs: src/zwirn-stream
+ exposed-modules: Zwirn.Stream.Handshake
+ Zwirn.Stream.Process
+ Zwirn.Stream.Types
+ Zwirn.Stream.UI
+ Zwirn.Stream.Listen
+ Zwirn.Stream.Target
+ Zwirn.Stream.Env
+ build-depends: zwirn:zwirn-core,
+ zwirn:zwirn-lang,
+ hosc >= 0.21.1 && < 0.22,
+ network >= 3.2.7 && < 3.3,
+ tidal-link >= 1.2.2 && < 1.3,
+
+library zwirn-doux
+ import: common-options,
+ common-deps
+ visibility: public
+ hs-source-dirs: src/zwirn-doux
+ exposed-modules: Zwirn.Doux.Env
+ Zwirn.Doux.Process
+ Zwirn.Doux.Types
+ Zwirn.Doux.UI
+ build-depends: zwirn:zwirn-core,
+ zwirn:zwirn-lang,
+ tidal-link >= 1.2.2 && < 1.3,
+ haskell-doux >= 0.2.4 && < 0.3,
+ time >= 1.14 && < 1.17
+
+flag superdirt
+ description: Use Superdirt as the audio backend
+ default: False
+ manual: True
+
executable zwirnzi
import: common-options,
common-deps
hs-source-dirs: app/zwirnzi
main-is: Main.hs
other-modules: CI.Backend
- CI.Setup
- CI.Config
LSP.Main
LSP.Diagnostic
LSP.Util
@@ -140,23 +171,108 @@
LSP.Handlers.InlayHint
build-depends: zwirn:zwirn-core,
zwirn:zwirn-lang,
- tidal-link >= 1.1 && < 1.2,
+ tidal-link >= 1.2.2 && < 1.3,
bytestring >= 0.12.1 && < 0.13,
exceptions >= 0.10.9 && < 0.11,
- lsp >= 2.7 && < 2.7.1,
+ lsp >= 2.8 && < 2.9,
haskeline >= 0.8.4 && < 0.9,
- file-io >= 0.1.5 && < 0.1.6,
- filepath >= 1.5.4 && < 1.5.5,
+ file-io >= 0.1.5 && < 0.3,
+ filepath >= 1.5.4 && < 1.6,
directory >= 1.3.9 && < 1.4,
conferer >= 1.1 && < 1.2,
conferer-yaml >= 1.1 && < 1.2,
utf8-string >= 1.0.2 && < 1.1,
- lens >= 5.3 && < 5.3.6,
+ lens >= 5.3 && < 5.4,
text-rope >= 0.3 && < 0.4,
- aeson >= 2.2.3 && < 2.2.4
+ aeson >= 2 && < 2.4
default-language: Haskell2010
ghc-options: -threaded
+ if flag(superdirt)
+ other-modules: CI.ConfigSuperDirt
+ CI.SetupSuperDirt
+ build-depends: zwirn:zwirn-stream,
+ yaml ^>=0.11.11.2
+ cpp-options: -DSTREAM_SUPERDIRT
+ else
+ other-modules: CI.ConfigDoux
+ CI.SetupDoux
+ build-depends: zwirn:zwirn-doux,
+ yaml ^>=0.11.11.2
+
+executable zwirnmill
+ import: common-options,
+ common-deps
+ main-is: Main.hs
+ other-modules: UI,
+ Editor.Config,
+ Editor.Core,
+ Editor.Cursor,
+ Editor.Diagnostic,
+ Editor.Draw,
+ Editor.Eval,
+ Editor.Event,
+ Editor.File,
+ Editor.Insertion,
+ Editor.Keymap,
+ Editor.Line,
+ Editor.Popup,
+ Editor.Selection,
+ Editor.Undo,
+ Editor.Util,
+ EnvBrowser.Draw,
+ EnvBrowser.Event,
+ SampleBrowser.Draw,
+ SampleBrowser.Event,
+ SampleBrowser.Load,
+ Keyboard.Draw,
+ Keyboard.Event,
+ UI.Attributes,
+ UI.Core,
+ UI.Config,
+ UI.Draw,
+ UI.Event,
+ UI.Window,
+ Docs.Draw,
+ Docs.Event,
+ Docs.Markdown,
+ Docs.Util,
+ Animation,
+ Keymap,
+ Config,
+ Setup,
+ Session,
+ Paths_zwirn
+ autogen-modules: Paths_zwirn
+ build-depends: time ^>=1.14,
+ microlens-th ^>=0.4.3.18,
+ yaml ^>=0.11.11.2,
+ microlens ^>=0.5.0.0,
+ zwirn:zwirn-lang,
+ zwirn:zwirn-doux,
+ zwirn:zwirn-core,
+ file-io >= 0.1.5 && < 0.3,
+ filepath >= 1.5.4 && < 1.6,
+ directory >= 1.3.9 && < 1.4,
+ conferer >= 1.1 && < 1.2,
+ conferer-yaml >= 1.1 && < 1.2,
+ utf8-string >= 1.0.2 && < 1.1,
+ bytestring >= 0.12.1 && < 0.13,
+ base64 >= 1.0 && < 1.1,
+ haskell-doux >= 0.2.5 && < 0.3,
+ vector ^>=0.13.2.0,
+ brick >=2.10 && < 2.14,
+ vty >=6.5 && < 6.7,
+ vty-crossplatform >=0.5 && < 0.7,
+ process ^>=1.6.25.0,
+ text-zipper >= 0.13 && < 0.14,
+ tinyfiledialogs >=0.2.1 && < 0.2.2,
+ commonmark >= 0.3 && < 0.4,
+ file-embed >= 0.0.16 && < 0.0.17
+ hs-source-dirs: app/zwirnmill
+ default-language: Haskell2010
+ ghc-options: -threaded -Wall -Wcompat
+
executable zwirn-plot
import: common-options,
common-deps
@@ -174,19 +290,19 @@
main-is: Main.hs
build-depends: zwirn:zwirn-lang,
directory >= 1.3.9 && < 1.4,
- file-io >= 0.1.5 && < 0.1.6,
- filepath >= 1.5.4 && < 1.5.5
+ file-io >= 0.1.5 && < 0.3,
+ filepath >= 1.5.4 && < 1.6
default-language: Haskell2010
ghc-options: -threaded
test-suite test-zwirn-core
+ import: common-options,
+ common-deps
type: exitcode-stdio-1.0
hs-source-dirs: test/zwirn-core/
main-is: Main.hs
build-depends: zwirn:zwirn-core,
- base >= 4.14 && < 4.22,
- containers >= 0.6.8 && < 0.8,
tasty >= 1.5,
tasty-smallcheck >= 0.8.2,
tasty-quickcheck >= 0.10.3,
@@ -214,7 +330,7 @@
hs-source-dirs: bench/Core
build-depends:
base >= 4.14 && < 4.22,
- criterion >=1.6.4 && < 1.6.5,
+ criterion >=1.6.4 && < 1.7,
deepseq,
zwirn:zwirn-core,
default-language: Haskell2010