packages feed

zwirn 0.2.2.1 → 0.2.3.1

raw patch · 92 files changed

+5983/−1132 lines, 92 filesdep +base64dep +brickdep +commonmarkdep ~aesondep ~containersdep ~criterionnew-component:exe:zwirnmill

Dependencies added: base64, brick, commonmark, file-embed, haskell-doux, microlens, microlens-th, process, text-zipper, time, tinyfiledialogs, vector, vty, vty-crossplatform, yaml

Dependency ranges changed: aeson, containers, criterion, file-io, filepath, lens, lsp, pure-noise, tidal-link

Files

README.md view
@@ -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+```
+ app/zwirnmill/Animation.hs view
@@ -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 ()
+ app/zwirnmill/Config.hs view
@@ -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 <http://www.gnu.org/licenses/>.+-}++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
+ app/zwirnmill/Docs/Draw.hs view
@@ -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)]
+ app/zwirnmill/Docs/Event.hs view
@@ -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'
+ app/zwirnmill/Docs/Markdown.hs view
@@ -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
+ app/zwirnmill/Docs/Util.hs view
@@ -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)
+ app/zwirnmill/Editor/Config.hs view
@@ -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
+ app/zwirnmill/Editor/Core.hs view
@@ -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+    }
+ app/zwirnmill/Editor/Cursor.hs view
@@ -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
+ app/zwirnmill/Editor/Diagnostic.hs view
@@ -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)
+ app/zwirnmill/Editor/Draw.hs view
@@ -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
+ app/zwirnmill/Editor/Eval.hs view
@@ -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
+ app/zwirnmill/Editor/Event.hs view
@@ -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
+ app/zwirnmill/Editor/File.hs view
@@ -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"]
+ app/zwirnmill/Editor/Insertion.hs view
@@ -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
+ app/zwirnmill/Editor/Keymap.hs view
@@ -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)
+ app/zwirnmill/Editor/Line.hs view
@@ -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
+ app/zwirnmill/Editor/Popup.hs view
@@ -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
+ app/zwirnmill/Editor/Selection.hs view
@@ -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)
+ app/zwirnmill/Editor/Undo.hs view
@@ -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."
+ app/zwirnmill/Editor/Util.hs view
@@ -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
+ app/zwirnmill/EnvBrowser/Draw.hs view
@@ -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
+ app/zwirnmill/EnvBrowser/Event.hs view
@@ -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}
+ app/zwirnmill/Keyboard/Draw.hs view
@@ -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 ' '))
+ app/zwirnmill/Keyboard/Event.hs view
@@ -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}
+ app/zwirnmill/Keymap.hs view
@@ -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)]
+ app/zwirnmill/Main.hs view
@@ -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}
+ app/zwirnmill/SampleBrowser/Draw.hs view
@@ -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 <> ")"
+ app/zwirnmill/SampleBrowser/Event.hs view
@@ -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 ()
+ app/zwirnmill/SampleBrowser/Load.hs view
@@ -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
+ app/zwirnmill/Session.hs view
@@ -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
+ app/zwirnmill/Setup.hs view
@@ -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 <http://www.gnu.org/licenses/>.+-}++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
+ app/zwirnmill/UI.hs view
@@ -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
+ app/zwirnmill/UI/Attributes.hs view
@@ -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)+    ]
+ app/zwirnmill/UI/Config.hs view
@@ -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+      ]
+ app/zwirnmill/UI/Core.hs view
@@ -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
+ app/zwirnmill/UI/Draw.hs view
@@ -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
+ app/zwirnmill/UI/Event.hs view
@@ -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
+ app/zwirnmill/UI/Window.hs view
@@ -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))
− app/zwirnzi/CI/Config.hs 
@@ -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 <http://www.gnu.org/licenses/>.--}--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
+ app/zwirnzi/CI/ConfigDoux.hs view
@@ -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
+ app/zwirnzi/CI/ConfigSuperDirt.hs view
@@ -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 <http://www.gnu.org/licenses/>.+-}++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
− app/zwirnzi/CI/Setup.hs 
@@ -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 <http://www.gnu.org/licenses/>.--}--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
+ app/zwirnzi/CI/SetupDoux.hs view
@@ -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
+ app/zwirnzi/CI/SetupSuperDirt.hs view
@@ -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 <http://www.gnu.org/licenses/>.+-}++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
app/zwirnzi/LSP/Handlers/Command.hs view
@@ -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
app/zwirnzi/LSP/Handlers/File.hs view
@@ -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
app/zwirnzi/LSP/Handlers/Hover.hs view
@@ -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 ()
app/zwirnzi/Main.hs view
@@ -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
+ docs/reference/time.md view
@@ -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 $: <rev id> [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]+```
+ docs/sidebar/overview.md view
@@ -0,0 +1,4 @@+[Welcome](welcome.md)++**Tutorial**+  [First Sounds](tutorial/start.md)
+ docs/sidebar/reference.md view
@@ -0,0 +1,3 @@+Reference++   [Functions Manipulating Time](reference/time.md)
+ docs/tutorial/start.md view
@@ -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)
+ docs/welcome.md view
@@ -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)
src/zwirn-core/Zwirn/Core/Cord.hs view
@@ -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
src/zwirn-core/Zwirn/Core/Lib/Cord.hs view
@@ -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
src/zwirn-core/Zwirn/Core/Lib/Map.hs view
@@ -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)
src/zwirn-core/Zwirn/Core/Lib/Modulate.hs view
@@ -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)
src/zwirn-core/Zwirn/Core/Lib/State.hs view
@@ -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
src/zwirn-core/Zwirn/Core/Query.hs view
@@ -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
src/zwirn-core/Zwirn/Core/Types.hs view
@@ -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]
+ src/zwirn-doux/Zwirn/Doux/Env.hs view
@@ -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"+    ]
+ src/zwirn-doux/Zwirn/Doux/Process.hs view
@@ -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
+ src/zwirn-doux/Zwirn/Doux/Types.hs view
@@ -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+    }
+ src/zwirn-doux/Zwirn/Doux/UI.hs view
@@ -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)
+ src/zwirn-lang/Zwirn/Language/Builtin/DouxParameters.hs view
@@ -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)+              ]+        )
src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs view
@@ -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
src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs view
@@ -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"     ]
src/zwirn-lang/Zwirn/Language/Compiler.hs view
@@ -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 ()
src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs view
@@ -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
src/zwirn-lang/Zwirn/Language/LSP/Hover.hs view
@@ -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
src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs view
@@ -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
src/zwirn-lang/Zwirn/Language/Lexer.x view
@@ -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 }
src/zwirn-lang/Zwirn/Language/Location.hs view
@@ -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)
+ src/zwirn-lang/Zwirn/Language/Play.hs view
@@ -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 <http://www.gnu.org/licenses/>.+-}++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
src/zwirn-lang/Zwirn/Language/Pretty.hs view
@@ -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
− src/zwirn-lang/Zwirn/Stream/Handshake.hs 
@@ -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 ()
− src/zwirn-lang/Zwirn/Stream/Listen.hs 
@@ -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
− src/zwirn-lang/Zwirn/Stream/Process.hs 
@@ -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)
− src/zwirn-lang/Zwirn/Stream/Target.hs 
@@ -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
− src/zwirn-lang/Zwirn/Stream/Types.hs 
@@ -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-  }
− src/zwirn-lang/Zwirn/Stream/UI.hs 
@@ -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)
+ src/zwirn-stream/Zwirn/Stream/Env.hs view
@@ -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"+        --| ""+    ]
+ src/zwirn-stream/Zwirn/Stream/Handshake.hs view
@@ -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 ()
+ src/zwirn-stream/Zwirn/Stream/Listen.hs view
@@ -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
+ src/zwirn-stream/Zwirn/Stream/Process.hs view
@@ -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
+ src/zwirn-stream/Zwirn/Stream/Target.hs view
@@ -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
+ src/zwirn-stream/Zwirn/Stream/Types.hs view
@@ -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+  }
+ src/zwirn-stream/Zwirn/Stream/UI.hs view
@@ -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)
test/zwirn-core/Main.hs view
@@ -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
zwirn.cabal view
@@ -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