packages feed

zwirn 0.1.0.0 → 0.2.2.0

raw patch · 91 files changed

+9021/−3727 lines, 91 filesdep +aesondep +confererdep +conferer-yamldep −prettydep −zwirn-coredep ~basedep ~containersdep ~exceptionsnew-component:exe:zwirn-docsnew-component:exe:zwirn-plotnew-component:exe:zwirnzi

Dependencies added: aeson, conferer, conferer-yaml, criterion, deepseq, directory, easyplot, file-io, haskeline, hmt, lens, lsp, prettyprinter, pure-noise, random, stm, tasty, tasty-hunit, tasty-quickcheck, tasty-smallcheck, text-rope, utf8-string, zwirn

Dependencies removed: pretty, zwirn-core

Dependency ranges changed: base, containers, exceptions, filepath, network

Files

README.md view
@@ -6,17 +6,13 @@  zwirn is an experiment in making the pattern language [TidalCycles](https://tidalcycles.org/) into a small functional language of it's own. while zwirn's internals are quite different from Tidal's, zwirns design owes almost everything to tidals design by [Alex McLean](https://slab.org/). -the internal representation of signals of time was implemented together (and parallel) with [Julian Rohrhuber](https://wertlos.org/~rohrhuber/), in an effort to port tidal to SuperCollider. This can be found in the seperate haskell library [zwirn-core](https://lab.al0.de/martin/zwirn-core).+the internal representation of signals of time was implemented together (and parallel) with [Julian Rohrhuber](https://wertlos.org/~rohrhuber/), in an effort to port tidal to SuperCollider. This can be found in the [zwirn-core](https://codeberg.org/uzu/zwirn/src/branch/main/src/zwirn-core/Zwirn/Core) sublibrary.  the implementation of the compiler is inspired by the excellent [Write You a Haskell](https://github.com/sdiehl/write-you-a-haskell) by Stephen Diehl.  ## Installing zwirn -There are currently two ways to play with zwirn:-  * [zwirnzi](https://github.com/polymorphicengine/zwirnzi) - the zwirn zompiler-interpreter-  * [zwirn-loom](https://github.com/polymorphicengine/zwirn-loom) - a compiler-interpreter for zwirn with an experimental editor interface--Zwirnzi is meant to serve as a way to play with zwirn in an editor of your choice, currently there are no official editor extensions - but it shouldn't be too hard to implement one. This means that zwirn-loom is the best way to play with zwirn at the moment.+tba  ## Limitations @@ -26,4 +22,4 @@  ## Documentation -documentation for zwirn is still in progress and available [here](https://github.com/polymorphicengine/zwirn/wiki), feel free to drop me a message if you have any questions.+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.
+ app/zwirn-docs/Main.hs view
@@ -0,0 +1,45 @@+module Main where++import Data.List (intercalate)+import qualified Data.Map as Map+import Data.Text (Text, unpack)+import Data.Text.Lazy as T (pack)+import Data.Text.Lazy.Encoding as T+import System.Directory.OsPath+import System.File.OsPath as F+import System.OsPath hiding (unpack)+import Zwirn.Language.Builtin.Prelude+import Zwirn.Language.Environment+import Zwirn.Language.Pretty++main :: IO ()+main = do+  curr <- getCurrentDirectory+  path <- (curr <>) <$> encodeUtf "/zwirn-docs.md"+  decoded <- decodeUtf path+  putStrLn ("Generating documentation in: " ++ decoded)+  F.writeFile path (T.encodeUtf8 $ T.pack documentation)++documentation :: String+documentation =+  "# Zwirn\n\n"+    ++ intercalate+      "\n\n"+      [ documentSection "Core Functions" coreFunctions,+        documentSection "Signals" signals,+        documentSection "Randomness" randomFunctions,+        documentSection "Manipulating Time" timeFunctions,+        documentSection "Manipulating Structure" structureFunctions,+        documentSection "Conditionals" conditionalFunctions,+        documentSection "Cords / Layers" cordFunctions,+        documentSection "Functions on Maps" mapFunctions+      ]++documentSection :: String -> Map.Map Text AnnotatedExpression -> String+documentSection header ma = "## " ++ header ++ "\n\n" ++ intercalate "\n\n" (map documentOne as)+  where+    as = Map.toList ma++documentOne :: (Text, AnnotatedExpression) -> String+documentOne (name, Annotated _ ty (Just desc)) = "```" ++ unpack name ++ " :: " ++ unpack (ppscheme ty) ++ "```\n\n" ++ unpack desc+documentOne (name, Annotated _ ty Nothing) = "```" ++ unpack name ++ " :: " ++ unpack (ppscheme ty) ++ "```"
+ app/zwirn-plot/Main.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.Monad (void)+import Control.Monad.Identity (Identity (..))+import Graphics.EasyPlot+import Zwirn.Core.Lib.Modulate+import Zwirn.Core.Lib.Number (range, sine)+import Zwirn.Core.Query+import Zwirn.Core.Time+import Zwirn.Core.Types++-- | the most simple zwirn - no stacks, no state, no value+type Zwirn = ZwirnT Identity () () ()++-- | silence will just throw an error+instance HasSilence Identity where+  silence = error "no silence"++-- | interpret a zwirn as a transformation of time+fromZwirn :: Zwirn -> Double -> Double+fromZwirn z d = fromRational $ tTime $ time $ fst $ unId $ unzwirn z (Time (toRational d) 1) ()+  where+    unId (Identity a) = a++-- | extract the zeroes of the fractional part of the inner time of a zwirn+toData :: Double -> Double -> Zwirn -> [(Double, Double)]+toData st en z = map (\(t, Value _ t2 _, _) -> (fromRational $ tTime t, fromRational $ tTime t2)) xs+  where+    (xs, _) = findAllBreakpoints 0.005 (Time (toRational st) 1) (Time (toRational en) 1) () z++-- | plots both the zwirns breakpoints and inner time+plotZwirn :: Zwirn -> [Graph2D Double Double]+plotZwirn z = [Function2D [] [Range 0 4, Step 0.005] (fromZwirn z), Data2D [Color Red] [] (toData 0 4 z)]++basic :: Zwirn+basic = pure ()++fastcatEx :: Zwirn+fastcatEx = fastcat [basic, basic]++timeLoopEx :: Zwirn+timeLoopEx = timeloop (pure 0.5) basic++zoomEx :: Zwirn+zoomEx = zoom (pure 0.5) (pure 1) fastcatEx++loopEx :: Zwirn+loopEx = loop (pure 0.5) (pure 1) fastcatEx++ribbonEx :: Zwirn+ribbonEx = ribbon (pure 0.5) (pure 0.75) fastcatEx++swingByEx :: Zwirn+swingByEx = swingBy (pure 0.5) (pure 4) (fast (pure 8) $ pure ())++revEx :: Zwirn+revEx = rev basic++weird :: Zwirn+weird = fast (range (pure 1) (pure 2) sine) basic++main :: IO ()+main = void $ plot X11 $ plotZwirn basic
+ app/zwirnzi/CI/Backend.hs view
@@ -0,0 +1,61 @@+module CI.Backend where++{-+    Backend.hs - Implements the interaction between the compiler-interpreter and the editor+    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 Control.Monad.State (lift, liftIO)+import Data.Text (pack)+import qualified Data.Text as T+import System.Console.Haskeline+import Zwirn.Language.Compiler+import Zwirn.Language.LSP.Eval (evalBlockAt)++type ZwirnCI = InputT CI++runZwirnCI :: Environment -> ZwirnCI () -> IO ()+runZwirnCI env x = do+  ci <- runCI env (runInputT defaultSettings x)+  case ci of+    Left (CIError err envv) -> print err >> runZwirnCI envv x+    Right _ -> return ()++evalInput :: ZwirnCI ()+evalInput = do+  mayinput <- getInputLine ">> "+  case mayinput of+    Just ":{" -> do+      input <- multiLineLoop ""+      ((_, ms), _) <- lift $ evalBlockAt (pack input) 1+      mapM_ (liftIO . putStrLn . T.unpack) ms+    Just input -> do+      x <- lift $ compilerInterpreterBasic (pack input)+      case x of+        OutMessage m -> liftIO $ putStrLn $ T.unpack m+        _ -> return ()+    Nothing -> return ()++multiLineLoop :: String -> ZwirnCI String+multiLineLoop s = do+  mayinput <- getInputLine ""+  case mayinput of+    Just ":}" -> return s+    Just t -> do multiLineLoop (s ++ "\n" ++ t)+    _ -> return ""++evalInputLoop :: ZwirnCI ()+evalInputLoop = evalInput >> evalInputLoop
+ app/zwirnzi/CI/Config.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultilineStrings #-}+{-# 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+    """++getFile :: String -> IO String+getFile p = do+  path <- encodeUtf p+  f <- F.readFile path+  return $ BL.toString f
+ app/zwirnzi/CI/Setup.hs view
@@ -0,0 +1,80 @@+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/LSP/Diagnostic.hs view
@@ -0,0 +1,88 @@+module LSP.Diagnostic where++import qualified Data.Text as T+import LSP.Util+import Language.LSP.Diagnostics+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server+import Zwirn.Language.Compiler+import Zwirn.Language.Location (Located (..), SrcLoc (..))+import Zwirn.Language.Rotate (RotationError (..))+import Zwirn.Language.TypeCheck.Constraint (TypeError (..))+import Zwirn.Language.TypeCheck.Types (Predicate (..))++type TextDocumentVersion = LSP.Int32++maxDiagnostics :: Int+maxDiagnostics = 16++publishDiags :: LSP.NormalizedUri -> Maybe TextDocumentVersion -> [LSP.Diagnostic] -> LSP ()+publishDiags doc version = publishDiagnostics maxDiagnostics doc version . partitionBySource++refreshDiagnostics :: LSP ()+refreshDiagnostics = flushDiagnosticsBySource maxDiagnostics (Just "zwirn-lsp")++makeErrorDiagnostic :: ErrorType -> [LSP.Diagnostic]+makeErrorDiagnostic (ParseErr msg r) =+  pure $+    LSP.Diagnostic+      (toLSP r)+      (Just LSP.DiagnosticSeverity_Error) -- severity+      Nothing -- code+      Nothing -- code description+      (Just "zwirn-lsp") -- source+      (T.pack msg)+      Nothing -- tags+      (Just []) -- related info+      Nothing -- data+makeErrorDiagnostic err@(RotErr (RotationError (SrcLoc r))) =+  pure $+    LSP.Diagnostic+      (toLSP r)+      (Just LSP.DiagnosticSeverity_Error)+      Nothing+      Nothing+      (Just "zwirn-lsp")+      (T.pack $ show err)+      Nothing+      (Just [])+      Nothing+makeErrorDiagnostic err@(TypeErr (NoInstance (Located (SrcLoc r) (IsIn _ _)))) =+  pure $+    LSP.Diagnostic+      (toLSP r)+      (Just LSP.DiagnosticSeverity_Error)+      Nothing+      Nothing+      (Just "zwirn-lsp")+      (T.pack $ show err)+      Nothing+      (Just [])+      Nothing+makeErrorDiagnostic err@(TypeErr (UnboundVariable (Located (SrcLoc r) _))) =+  pure $+    LSP.Diagnostic+      (toLSP r)+      (Just LSP.DiagnosticSeverity_Error)+      Nothing+      Nothing+      (Just "zwirn-lsp")+      (T.pack $ show err)+      Nothing+      (Just [])+      Nothing+makeErrorDiagnostic err@(TypeErr (UnificationFail (Located (SrcLoc r) _))) =+  pure $+    LSP.Diagnostic+      (toLSP r)+      (Just LSP.DiagnosticSeverity_Error)+      Nothing+      Nothing+      (Just "zwirn-lsp")+      (T.pack (show err))+      Nothing+      (Just [])+      Nothing+makeErrorDiagnostic (ManyErr errs) = concatMap makeErrorDiagnostic errs+makeErrorDiagnostic _ = []
+ app/zwirnzi/LSP/Handlers/Action.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE RecordWildCards #-}++module LSP.Handlers.Action where++import Control.Lens ((^.))+import qualified Data.Aeson as J+import LSP.Util+import qualified Language.LSP.Protocol.Lens as LSP+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (Handlers, requestHandler)++codeActionHandler :: Handlers LSP+codeActionHandler = requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do+  let LSP.CodeActionParams _ _ doc range _ = req ^. LSP.params+  -- uri = doc ^. LSP.uri+  -- debug (T.pack $ "Processing custom code action" ++ show range)+  let title = "Evaluate zwirn code at cursor"+      -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above+      cmd = "zwirn-eval"+      args =+        [ J.toJSON doc,+          J.toJSON range+        ]+      command = LSP.Command title cmd (Just args)+  let action = LSP.CodeAction {..}+        where+          _title = "eval"+          _kind = Just $ LSP.CodeActionKind_Custom "zwirn"+          _diagnostics = Nothing+          _isPreferred = Nothing+          _disabled = Nothing+          _edit = Nothing+          _command = Just command+          _data_ = Nothing+  responder $ Right $ LSP.InL $ LSP.InR <$> [action]
+ app/zwirnzi/LSP/Handlers/Command.hs view
@@ -0,0 +1,79 @@+module LSP.Handlers.Command where++import Control.Concurrent.MVar+import Control.Lens ((^.))+import Control.Monad (void)+import Control.Monad.IO.Class+import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+import qualified Data.Map as Map+import qualified Data.Text as T+import LSP.Diagnostic+import LSP.Handlers.InlayHint+import LSP.Util+import qualified Language.LSP.Protocol.Lens as LSP+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (Handlers, getVirtualFile, requestHandler, sendRequest)+import Language.LSP.VFS+import Zwirn.Language.Compiler+import Zwirn.Language.LSP.Diagnostics+import Zwirn.Language.LSP.Eval+import Zwirn.Language.Macro (CodeEdit (..))++-- TODO: make this more efficient?+-- currently the document is parsed three times, once for executing code, once for validating it after and once for generating new inlay hints ...+execCommandHandler :: MVar Environment -> Handlers LSP+execCommandHandler envmv = requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do+  debug "Processing a workspace/executeCommand request"+  let params = req ^. LSP.params+      -- name = params ^. LSP.command+      margs = params ^. LSP.arguments++  -- debug ("The arguments are: " <> show margs)+  responder (Right $ LSP.InR LSP.Null) -- respond to the request+  env <- liftIO $ takeMVar envmv+  case getEvalArgs margs of+    Nothing -> liftIO $ putMVar envmv env+    Just (docid, LSP.Range begin _) -> do+      let uri = docid ^. LSP.uri+          doc = LSP.toNormalizedUri uri+      mdoc <- getVirtualFile doc+      case mdoc of+        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+              liftIO $ putMVar envmv newEnv+              if null msgs then sendInfo "OK" else mapM_ sendInfo msgs+              makeEdits edits uri+              errs <- liftIO $ validateCode newEnv (virtualFileText vf)+              case errs of+                Just err -> publishDiags doc (Just (fromIntegral version)) (makeErrorDiagnostic err)+                Nothing -> refreshDiagnostics+              refreshHints+            Left err -> do+              liftIO $ putMVar envmv env+              sendError (T.pack $ show err)+        Nothing -> return ()+      return ()++getEvalArgs :: Maybe [J.Value] -> Maybe (LSP.TextDocumentIdentifier, LSP.Range)+getEvalArgs (Just [t, x]) = do+  doc <- J.parseMaybe J.parseJSON t+  pos <- J.parseMaybe J.parseJSON x+  return (doc, pos)+getEvalArgs _ = Nothing++makeEdits :: [CodeEdit] -> LSP.Uri -> LSP ()+makeEdits edits uri = do+  let lspedits = map toLSPEdit edits+      par =+        LSP.ApplyWorkspaceEditParams (Just "Howdy edit") $+          LSP.WorkspaceEdit (Just (Map.singleton uri lspedits)) Nothing Nothing++  void $ sendRequest LSP.SMethod_WorkspaceApplyEdit par (const (pure ()))++toLSPEdit :: CodeEdit -> LSP.TextEdit+toLSPEdit (CodeEdit pos x) = LSP.TextEdit (toLSP pos) x
+ app/zwirnzi/LSP/Handlers/Completion.hs view
@@ -0,0 +1,46 @@+module LSP.Handlers.Completion where++import Control.Concurrent (MVar)+import Control.Concurrent.MVar (readMVar)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Map as Map+import qualified Data.Text as T+import LSP.Util (LSP)+import Language.LSP.Protocol.Message (SMethod (..))+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (Handlers, requestHandler)+import Zwirn.Language (Environment (..), InterpreterEnv (..))+import Zwirn.Language.Environment (AnnotatedExpression (..))+import Zwirn.Language.Pretty (ppscheme)+import Zwirn.Language.TypeCheck.Types (Scheme)++completionHandler :: MVar Environment -> Handlers LSP+completionHandler envMV = requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do+  env <- liftIO $ readMVar envMV++  let ks = map (\(k, Annotated _ s _) -> (k, s)) $ Map.toList $ eExpressions $ intEnv env+      res = LSP.CompletionList True Nothing (map mkCompletionItem ks)+  resp $ Right $ LSP.InR $ LSP.InL res+  where+    mkCompletionItem :: (T.Text, Scheme) -> LSP.CompletionItem+    mkCompletionItem (k, s) =+      LSP.CompletionItem+        k+        Nothing+        (Just LSP.CompletionItemKind_Constant)+        Nothing+        (Just $ ppscheme s)+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing
+ app/zwirnzi/LSP/Handlers/File.hs view
@@ -0,0 +1,58 @@+module LSP.Handlers.File where++import Control.Concurrent.MVar+import Control.Lens (to, (^.))+import Control.Monad.IO.Class+import LSP.Diagnostic+import LSP.Util+import qualified Language.LSP.Protocol.Lens as LSP+import Language.LSP.Protocol.Message+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (Handlers, getVirtualFile, notificationHandler)+import Language.LSP.VFS+import Zwirn.Language.Compiler+import Zwirn.Language.LSP.Diagnostics++didSaveHandler :: MVar Environment -> Handlers LSP+didSaveHandler envMV = notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do+  let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri+      mcont = msg ^. LSP.params . LSP.text+  case mcont of+    Just content -> do+      env <- liftIO $ readMVar envMV+      errs <- liftIO $ validateCode env content+      case errs of+        Just err -> publishDiags (LSP.toNormalizedUri doc) Nothing (makeErrorDiagnostic err)+        Nothing -> refreshDiagnostics+    Nothing -> return ()++didOpenHandler :: MVar Environment -> Handlers LSP+didOpenHandler envMV = notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do+  let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri+      content = msg ^. LSP.params . LSP.textDocument . LSP.text+  env <- liftIO $ readMVar envMV+  errs <- liftIO $ validateCode env content+  case errs of+    Just err -> publishDiags (LSP.toNormalizedUri doc) Nothing (makeErrorDiagnostic err)+    Nothing -> refreshDiagnostics++didCloseHandler :: Handlers LSP+didCloseHandler = notificationHandler LSP.SMethod_TextDocumentDidClose $ const $ return ()++didChangeHandler :: MVar Environment -> Handlers LSP+didChangeHandler envMV = notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do+  let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri+  mdoc <- getVirtualFile doc+  case mdoc of+    Just vf@(VirtualFile _ version _rope) -> do+      env <- liftIO $ readMVar envMV+      errs <- liftIO $ validateCode env (virtualFileText vf)+      case errs of+        Just err -> publishDiags doc (Just (fromIntegral version)) (makeErrorDiagnostic err)+        Nothing -> refreshDiagnostics+    _ -> debug "No virtual file found!"++cancelationHandler :: Handlers LSP+cancelationHandler = notificationHandler SMethod_CancelRequest $ \_ -> return ()
+ app/zwirnzi/LSP/Handlers/Hover.hs view
@@ -0,0 +1,30 @@+module LSP.Handlers.Hover where++import Control.Concurrent.MVar+import Control.Lens (to, (^.))+import Control.Monad.IO.Class+import LSP.Util+import qualified Language.LSP.Protocol.Lens as LSP+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (Handlers, getVirtualFile, requestHandler)+import Language.LSP.VFS+import Zwirn.Language.Compiler+import Zwirn.Language.LSP.Hover++hoverHandler :: MVar Environment -> Handlers LSP+hoverHandler envMV = requestHandler+  LSP.SMethod_TextDocumentHover+  $ \req responder -> do+    let doc = req ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri+        pos = req ^. LSP.params . LSP.position . to fromLSPPos+    mdoc <- getVirtualFile doc+    env <- liftIO $ readMVar envMV+    case mdoc of+      Just vf -> do+        mci <- liftIO $ runCI env (parseAndGetInfoAt (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 ()+      Nothing -> return ()
+ app/zwirnzi/LSP/Handlers/InlayHint.hs view
@@ -0,0 +1,37 @@+module LSP.Handlers.InlayHint where++import Control.Concurrent.MVar+import Control.Lens (to, (^.))+import Control.Monad (void)+import Control.Monad.IO.Class+import LSP.Util+import qualified Language.LSP.Protocol.Lens as LSP+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (Handlers, getVirtualFile, requestHandler, sendRequest)+import Language.LSP.VFS+import Zwirn.Language.Compiler+import Zwirn.Language.LSP.InlayHints (Hint (..), getHints)++inlayHintHandler :: MVar Environment -> Handlers LSP+inlayHintHandler envMV = requestHandler LSP.SMethod_TextDocumentInlayHint $ \req responder -> do+  let doc = req ^. LSP.params . LSP.textDocument . LSP.uri . to LSP.toNormalizedUri++  mdoc <- getVirtualFile doc+  env <- liftIO $ readMVar envMV+  psHints <- case mdoc of+    Just vf -> do+      hci <- liftIO $ runCI env (getHints (virtualFileText vf))+      case hci of+        Right hs -> return $ map mkHint hs+        _ -> return []+    Nothing -> return []++  responder $ Right $ LSP.InL psHints++mkHint :: Hint -> LSP.InlayHint+mkHint (Hint pos ct desc) = LSP.InlayHint (toLSPPos pos) (LSP.InL ct) Nothing Nothing (Just $ LSP.InL desc) Nothing Nothing Nothing++refreshHints :: LSP ()+refreshHints = void $ sendRequest LSP.SMethod_WorkspaceInlayHintRefresh Nothing (const $ return ())
+ app/zwirnzi/LSP/Main.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module LSP.Main where++import Control.Concurrent.MVar+import Control.Monad.IO.Class+import LSP.Handlers.Action+import LSP.Handlers.Command+import LSP.Handlers.Completion+import LSP.Handlers.File+import LSP.Handlers.Hover+import LSP.Handlers.InlayHint+import LSP.Util+import qualified Language.LSP.Protocol.Message as LSP+import Language.LSP.Protocol.Types ()+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server+import Zwirn.Language.Compiler++main :: MVar Environment -> IO Int+main envMV = runServer def+  where+    def :: ServerDefinition ()+    def =+      ServerDefinition+        { parseConfig = \oldEnv _ -> Right oldEnv,+          onConfigChange = const $ pure (),+          defaultConfig = (),+          configSection = "demo",+          doInitialize = \env _req -> pure $ Right env,+          staticHandlers = \_caps -> handlers envMV,+          interpretHandler = \env -> Iso (runLspT env) liftIO,+          options = lspOptions+        }++syncOptions :: LSP.TextDocumentSyncOptions+syncOptions =+  LSP.TextDocumentSyncOptions+    { LSP._openClose = Just True,+      LSP._change = Just LSP.TextDocumentSyncKind_Incremental,+      LSP._willSave = Just False,+      LSP._willSaveWaitUntil = Just False,+      LSP._save = Just $ LSP.InR $ LSP.SaveOptions $ Just False+    }++lspOptions :: Options+lspOptions =+  defaultOptions+    { optTextDocumentSync = Just syncOptions,+      optExecuteCommandCommands = Just ["zwirn-eval"]+    }++handlers :: MVar Environment -> Handlers LSP+handlers envMV =+  mconcat+    [ notificationHandler LSP.SMethod_Initialized $ \_not -> debug "Initialising server.",+      notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \_ -> return (),+      codeActionHandler,+      -- codeLensHandler,+      -- codeLensResolveHandler,+      inlayHintHandler envMV,+      execCommandHandler envMV,+      didSaveHandler envMV,+      didOpenHandler envMV,+      didCloseHandler,+      didChangeHandler envMV,+      hoverHandler envMV,+      completionHandler envMV,+      cancelationHandler+    ]++-- zed doesn't support showing code lenses in the document yet+-- but they might be a good way to display different available commands+-- codeLensHandler :: Handlers LSP+-- codeLensHandler = requestHandler LSP.SMethod_TextDocumentCodeLens $ \_ _ -> return ()++-- codeLensResolveHandler :: Handlers LSP+-- codeLensResolveHandler = requestHandler LSP.SMethod_CodeLensResolve $ \_ _ -> return ()
+ app/zwirnzi/LSP/Util.hs view
@@ -0,0 +1,40 @@+module LSP.Util where++import Control.Monad (void)+import qualified Data.Text as T+import qualified Language.LSP.Protocol.Message as LSP+import qualified Language.LSP.Protocol.Types as LSP+import Language.LSP.Server (LspM, sendNotification)+import Zwirn.Language.Location++type LSP = LspM ()++sendError :: T.Text -> LSP ()+sendError err =+  void $ sendNotification+      LSP.SMethod_WindowShowMessage+      ( LSP.ShowMessageParams+          LSP.MessageType_Error+          err+      )++sendInfo :: T.Text -> LSP ()+sendInfo msg =+  void $ sendNotification+      LSP.SMethod_WindowShowMessage+      ( LSP.ShowMessageParams+          LSP.MessageType_Info+          msg+      )++fromLSP :: T.Text -> LSP.Range -> RealSrcLoc+fromLSP t (LSP.Range (LSP.Position lst cst) (LSP.Position len cen)) = RealSrcLoc t (fromIntegral lst) (fromIntegral cst + 1) (fromIntegral len) (fromIntegral cen + 1)++toLSP :: RealSrcLoc -> LSP.Range+toLSP (RealSrcLoc _ lst cst len cen) = LSP.Range (LSP.Position (fromIntegral lst) (fromIntegral cst - 1)) (LSP.Position (fromIntegral len) (fromIntegral cen - 1))++fromLSPPos :: LSP.Position -> Position+fromLSPPos (LSP.Position l c) = Position (fromIntegral l) (fromIntegral c + 1)++toLSPPos :: Position -> LSP.Position+toLSPPos (Position l c) = LSP.Position (fromIntegral l) (fromIntegral c - 1)
+ app/zwirnzi/Main.hs view
@@ -0,0 +1,47 @@+module Main where++{-+    Main.hs - entry point of the editor program+    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.Backend+import CI.Config+import CI.Setup+import Conferer as Conf+import Control.Concurrent.MVar+import Control.Monad (void)+import qualified LSP.Main as LSP+import System.IO (BufferMode (..), hSetBuffering, stdin, stdout)++main :: IO ()+main = do+  hSetBuffering stdin NoBuffering++  config <- getConfig+  fullConfig <- Conf.fetch config+  env <- setup fullConfig+  envMV <- newMVar env+  if 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
+ bench/Core/Main.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.DeepSeq+import Criterion.Main+import Data.Functor.Identity+import GHC.Generics (Generic)+import Zwirn.Core.Cord (Cord, stack)+import qualified Zwirn.Core.Lib.Core as C+import Zwirn.Core.Lib.Modulate (fast)+import Zwirn.Core.Query+import Zwirn.Core.Time (Time (..))+import Zwirn.Core.Types (ZwirnT)++deriving instance Generic Time++deriving instance NFData Time++test :: Cord () () Int+test = fast (stack (replicate 10 (pure 23))) $ stack (replicate 10 (pure 1))++test2 :: Cord () () Int+test2 = C.iterate (pure 100) (pure $ fmap (+ 1)) test++test3 :: ZwirnT Identity () () Int+test3 = fast (pure 23) (pure 1)++main :: IO ()+main =+  defaultMain+    [ bgroup+        "oldquery"+        [ bench "" $ nf (\arc -> findAllValuesWithTime arc () test) (0, 1),+          bench "" $ nf (\arc -> findAllValuesWithTime arc () test2) (0, 1),+          bench "" $ nf (\arc -> findAllValuesWithTime arc () test3) (0, 1)+        ]+    ]
− src/Zwirn/Language.hs 
@@ -1,44 +0,0 @@-module Zwirn.Language-  ( module Zwirn.Language.Block,-    module Zwirn.Language.Compiler,-    module Zwirn.Language.Lexer,-    module Zwirn.Language.Parser,-    module Zwirn.Language.Pretty,-    module Zwirn.Language.Simple,-    module Zwirn.Language.Syntax,-    module Zwirn.Language.TypeCheck.Constraint,-    module Zwirn.Language.Environment,-    module Zwirn.Language.TypeCheck.Infer,-    module Zwirn.Language.TypeCheck.Types,-  )-where--import Zwirn.Language.Block-import Zwirn.Language.Compiler-import Zwirn.Language.Environment-import Zwirn.Language.Lexer-import Zwirn.Language.Parser-import Zwirn.Language.Pretty-import Zwirn.Language.Simple-import Zwirn.Language.Syntax-import Zwirn.Language.TypeCheck.Constraint-import Zwirn.Language.TypeCheck.Infer-import Zwirn.Language.TypeCheck.Types--{--    Language.hs - re-exports of all zwirn language modules-    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/>.--}
− src/Zwirn/Language/Block.hs 
@@ -1,44 +0,0 @@-module Zwirn.Language.Block-    ( Block (..)-    , BlockError-    , getBlock-    , getLn-    ) where--{--    Block.hs - parsing blocks of code and getting blocks at a specific line-    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 Data.Text as Text (Text, lines)--data Block = Block {bStart :: Int-                   ,bEnd :: Int-                   ,bContent :: Text-                   } deriving (Show, Eq)--type BlockError = String--getBlock :: Int -> [Block] -> Either BlockError Block-getBlock _ [] = Left "no block of code at current line"-getBlock num (block@(Block n1 n2 _):bs) = if n1 <= num && num <= n2-                                          then Right block-                                          else getBlock num bs--getLn :: Int -> [Block] -> Either BlockError Text-getLn i bs = do-         (Block start _ cont) <- getBlock i bs-         return $ (Text.lines cont)!!(i-start)
− src/Zwirn/Language/Builtin/Internal.hs 
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -Wno-orphans #-}--module Zwirn.Language.Builtin.Internal where--import qualified Data.Map as Map-import Data.String-import Data.Text (Text, pack)-import Zwirn.Language.Environment-import Zwirn.Language.Evaluate hiding (insert)-import Zwirn.Language.Parser (parseScheme)-import Zwirn.Language.TypeCheck.Types--instance IsString Scheme where-  fromString s = fromEither $ parseScheme (pack s)-    where-      fromEither (Right r) = r-      fromEither (Left e) = error e--(===) :: Text -> Expression -> Map.Map Text Expression-(===) = Map.singleton--(<::) :: Map.Map Text Expression -> Scheme -> Map.Map Text (Expression, Scheme)-(<::) x s = fmap (\l -> (l, s)) x--(--|) :: Map.Map Text (Expression, Scheme) -> Text -> Map.Map Text AnnotatedExpression-(--|) n t = fmap (\(x, s) -> Annotated x s (Just t)) n--noDesc :: Map.Map Text (Expression, Scheme) -> Map.Map Text AnnotatedExpression-noDesc = fmap (\(x, s) -> Annotated x s Nothing)
− src/Zwirn/Language/Builtin/Parameters.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Zwirn.Language.Builtin.Parameters where--import qualified Data.Map as Map-import Data.Text (Text)-import Zwirn.Core.Map-import Zwirn.Language.Builtin.Internal-import Zwirn.Language.Environment-import Zwirn.Language.Evaluate (Expression, Zwirn, toExp)--builtinParams :: Map.Map Text AnnotatedExpression-builtinParams = addAliases aliases $ Map.unions [builtinTextParams, builtinNumberParams, builtinIntParams]--builtinTextParams :: Map.Map Text AnnotatedExpression-builtinTextParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Text -> Zwirn Expression) <:: "Text -> Map") textParams--builtinNumberParams :: Map.Map Text AnnotatedExpression-builtinNumberParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Double -> Zwirn Expression) <:: "Number -> Map") numberParams--builtinIntParams :: Map.Map Text AnnotatedExpression-builtinIntParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Int -> Zwirn Expression) <:: "Number -> Map") intParams--textParams :: [Text]-textParams = ["s", "unit", "vowel", "toArg"]--intParams :: [Text]-intParams = ["cut", "orbit"]--numberParams :: [Text]-numberParams =-  [ "accelerate",-    "amp",-    "attack",-    "bandf",-    "bandq",-    "begin",-    "binshift",-    "ccn",-    "ccv",-    "channel",-    "coarse",-    "comb",-    "crush",-    "cutoff",-    "decay",-    "delay",-    "delaytime",-    "detune",-    "distort",-    "djf",-    "dry",-    "dur",-    "end",-    "enhance",-    "expression",-    "fadeInTime",-    "fadeTime",-    "freeze",-    "freq",-    "from",-    "fshift",-    "gain",-    "gate",-    "harmonic",-    "hbrick",-    "hcutoff",-    "hold",-    "hresonance",-    "imag",-    "krush",-    "lagogo",-    "lbrick",-    "legato",-    "leslie",-    "lock",-    "midibend",-    "miditouch",-    "modwheel",-    "n",-    "note",-    "nudge",-    "octave",-    "octer",-    "octersub",-    "octersubsub",-    "offset",-    "overgain",-    "overshape",-    "pan",-    "panorient",-    "panspan",-    "pansplay",-    "panwidth",-    "partials",-    "phaserdepth",-    "phaserrate",-    "rate",-    "real",-    "release",-    "resonance",-    "ring",-    "ringdf",-    "ringf",-    "room",-    "sagogo",-    "scram",-    "shape",-    "size",-    "slide",-    "smear",-    "speed",-    "squiz",-    "sustain",-    "sustainpedal",-    "timescale",-    "timescalewin",-    "to",-    "tremolodepth",-    "tremolorate",-    "triode",-    "tsdelay",-    "velocity",-    "voice",-    "waveloss",-    "xsdelay"-  ]--aliases :: [(Text, Text)]-aliases =-  [ ("sound", "s"),-    ("voi", "voice"),-    ("up", "n"),-    ("tremr", "tremolorate"),-    ("tremdp", "tremolodepth"),-    ("sz", "size"),-    ("sus", "sustain"),-    ("sld", "slide"),-    ("scr", "scrash"),-    ("rel", "release"),-    ("por", "portamento"),-    ("phasr", "phaserrate"),-    ("phasdp", "phaserdepth"),-    ("number", "n"),-    ("lpq", "resonance"),-    ("lpf", "cutoff"),-    ("hpq", "hresonance"),-    ("hpf", "hcutoff"),-    ("gat", "gate"),-    ("fadeOutTime", "fadeTime"),-    ("dt", "delaytime"),-    ("dfb", "delayfeedback"),-    ("det", "detune"),-    ("delayt", "delaytime"),-    ("delayfb", "delayfeedback"),-    ("ctf", "cutoff"),-    ("bpq", "bandq"),-    ("bpf", "bandf"),-    ("att", "attack")-  ]--addAliases :: [(Text, Text)] -> Map.Map Text AnnotatedExpression -> Map.Map Text AnnotatedExpression-addAliases as x = Map.unions $ map look as ++ [x]-  where-    look (y, n) = case Map.lookup n x of-      Just a -> Map.singleton y a-      Nothing -> Map.empty
− src/Zwirn/Language/Builtin/Prelude.hs 
@@ -1,616 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-orphans #-}--module Zwirn.Language.Builtin.Prelude where--{--    Builtin.hs - defines builtin functions-    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 qualified Data.Map as Map-import Data.Text (Text)-import Zwirn.Core.Conditional as Z-import Zwirn.Core.Cord as C-import Zwirn.Core.Core as C-import Zwirn.Core.Map as M-import Zwirn.Core.Modulate-import Zwirn.Core.Number as N-import Zwirn.Core.Random-import Zwirn.Core.Structure as S-import Zwirn.Core.Time-import Zwirn.Language.Builtin.Internal-import Zwirn.Language.Builtin.Parameters-import Zwirn.Language.Environment-import Zwirn.Language.Evaluate hiding (insert)-import Zwirn.Language.TypeCheck.Types--builtinEnvironment :: InterpreterEnv-builtinEnvironment = IEnv builtins instances--instances :: [Instance]-instances =-  [ IsIn "Num" numberT,-    IsIn "Num" mapT,-    IsIn "Eq" numberT,-    IsIn "Eq" mapT,-    IsIn "Eq" textT-  ]--builtinNames :: [Text]-builtinNames = Map.keys builtins--builtins :: Map.Map Text AnnotatedExpression-builtins =-  Map.unions-    [ coreFunctions,-      numberFunctions,-      signals,-      randomFunctions,-      timeFunctions,-      structureFunctions,-      conditionalFunctions,-      cordFunctions,-      mapFunctions,-      stateFunctions,-      builtinParams-    ]--coreFunctions :: Map.Map Text AnnotatedExpression-coreFunctions =-  Map.unions-    [ "id"-        === lambda id-        <:: "a -> a"-        --| "identity function",-      "const"-        === lambda (lambda . const)-        <:: "a -> b -> a"-        --| "constant function - ignore second input",-      "scomb"-        === lambda (\f -> lambda $ \g -> lambda $ \x -> f ! x ! (g ! x))-        <:: "(a -> b -> c) -> (a -> b) -> a -> c"-        --| "S-combinator",-      "."-        === lambda (\g -> lambda $ \f -> lambda $ \x -> g ! (f ! x))-        <:: "(b -> c) -> (a -> b) -> a -> c"-        --| "function composition",-      "flip"-        === lambda (\f -> lambda $ \y -> lambda $ \x -> f ! x ! y)-        <:: "(a -> b -> c) -> b -> a -> c"-        --| "flip arguments",-      "\'"-        === toExp (flip squeezeApply :: Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression)-        <:: "a -> (a -> b) -> b"-        --| "apply argument to function, results are squeezed",-      "$"-        === toExp (squeezeApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "(a -> b) -> a -> b"-        --| "apply argument to function, results are squeezed",-      "|$"-        === toExp (outerApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "(a -> b) -> a -> b"-        --| "apply argument to function",-      "$|"-        === toExp (innerApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "(a -> b) -> a -> b"-        --| "apply argument to function",-      "map"-        === toExp (mapZ :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "(a -> b) -> a -> b"-        --| "map a function over the structure of the argument",-      "zip"-        === toExp (zipApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "(a -> b) -> a -> b"-        --| "map a function over the structure of the argument",-      "bus"-        === toExp (id :: Zwirn Expression -> Zwirn Expression)-        <:: "Number -> Bus"-        --| "controlbus",-      "recv"-        === toExp (toExp recv)-        <:: "Text -> Number -> Map"-        --| "recieve a value from a bus and send it to the given parameter"-    ]--numberFunctions :: Map.Map Text AnnotatedExpression-numberFunctions =-  Map.unions-    [ "|+"-        === toExp ((+) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a -> a"-        --| "addition",-      "|-"-        === toExp ((-) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a -> a"-        --| "subtraction",-      "|*"-        === toExp ((*) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a -> a"-        --| "multiplication",-      "|/"-        === toExp ((/) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a -> a"-        --| "division",-      "negate"-        === toExp (negate :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "negate",-      "abs"-        === toExp (abs :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "absolute value",-      "signum"-        === toExp (signum :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a =>  a -> a"-        --| "signum",-      "recip"-        === toExp (recip :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "reciprocal value",-      "pi"-        === toExp (pi :: Zwirn Expression)-        <:: "Number"-        --| "pi",-      "|**"-        === toExp ((**) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a -> a"-        --| "exponentiation",-      "exp"-        === toExp (exp :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "exponential function",-      "log"-        === toExp (log :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "logarithm base 10",-      "sqrt"-        === toExp (sqrt :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a =>  a -> a"-        --| "square root",-      "sin"-        === toExp (sin :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "sine function",-      "cos"-        === toExp (cos :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "cosine function",-      "tan"-        === toExp (tan :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "tangens",-      "asin"-        === toExp (asin :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "arc sine function",-      "acos"-        === toExp (acos :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "arc cosine function",-      "atan"-        === toExp (atan :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "arc tangens",-      "sinh"-        === toExp (sinh :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "hyperbolic sine",-      "cosh"-        === toExp (cosh :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a =>  a -> a"-        --| "hyperbolic cosine",-      "tanh"-        === toExp (tan :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "hyperbolic tangens",-      "asinh"-        === toExp (asinh :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "hyperbolic arc sine function",-      "acosh"-        === toExp (acosh :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "hyperbolic arc cosine function",-      "atanh"-        === toExp (atanh :: Zwirn Expression -> Zwirn Expression)-        <:: "Num a => a -> a"-        --| "hyperbolic arc tangens",-      "mod"-        === toExp (N.mod :: Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number"-        --| "modulo",-      "frac"-        === toExp (N.frac :: Zwirn Double -> Zwirn Double)-        <:: "Number -> Number"-        --| "fractional part of a number",-      "trunc"-        === toExp (N.trunc :: Zwirn Double -> Zwirn Int)-        <:: "Number -> Number"-        --| "truncate",-      "ceil"-        === toExp (N.ceil :: Zwirn Double -> Zwirn Int)-        <:: "Number -> Number"-        --| "round up",-      "floor"-        === toExp (N.floor :: Zwirn Double -> Zwirn Int)-        <:: "Number -> Number"-        --| "round down",-      "round"-        === toExp (N.round :: Zwirn Double -> Zwirn Int)-        <:: "Number -> Number"-        --| "round to closest",-      "gcd"-        === toExp (N.gcd :: Zwirn Int -> Zwirn Int -> Zwirn Int)-        <:: "Number -> Number -> Number"-        --| "greatest common divisor",-      "lcm"-        === toExp (N.lcm :: Zwirn Int -> Zwirn Int -> Zwirn Int)-        <:: "Number -> Number -> Number"-        --| "least common multiple",-      "range"-        === toExp (range :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number -> Number"-        --| "range x y l maps number l linearly into interval (x,y), assuming l is between 0 and 1"-    ]--signals :: Map.Map Text AnnotatedExpression-signals =-  Map.unions-    [ "sine"-        === toExp (sine :: Zwirn Time)-        <:: "Number"-        --| "sine signal",-      "sine2"-        === toExp (sine2 :: Zwirn Time)-        <:: "Number"-        --| "bipolar sine signal",-      "saw"-        === toExp (saw :: Zwirn Time)-        <:: "Number"-        --| "saw signal",-      "saw2"-        === toExp (saw2 :: Zwirn Time)-        <:: "Number"-        --| "bipolar saw signal",-      "cosine"-        === toExp (cosine :: Zwirn Time)-        <:: "Number"-        --| "cosine signal",-      "cosine2"-        === toExp (cosine2 :: Zwirn Time)-        <:: "Number"-        --| "bipolar cosine signal",-      "isaw"-        === toExp (isaw :: Zwirn Time)-        <:: "Number"-        --| "inverse saw signal",-      "isaw2"-        === toExp (isaw2 :: Zwirn Time)-        <:: "Number"-        --| "bipolar inverse saw signal",-      "tri"-        === toExp (tri :: Zwirn Time)-        <:: "Number"-        --| "triangle signal",-      "tri2"-        === toExp (tri2 :: Zwirn Time)-        <:: "Number"-        --| "bipolar triangle signal",-      "square"-        === toExp (square :: Zwirn Time)-        <:: "Number"-        --| "square signal",-      "square2"-        === toExp (square2 :: Zwirn Time)-        <:: "Number"-        --| "bipolar square signal"-    ]--randomFunctions :: Map.Map Text AnnotatedExpression-randomFunctions =-  Map.unions-    [ "noise"-        === toExp (noise :: Zwirn Double)-        <:: "Number"-        --| "random stream of values between 0 and 1",-      "irand"-        === toExp (irand :: Zwirn Int -> Zwirn Int)-        <:: "Number -> Number"-        --| "random integer values between 0 and given input",-      "chooseFromTo"-        === toExp (enumFromToChoice 0 :: Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number"-        --| "```chooseFromTo x y == [x | .. y]```",-      "chooseFromThenTo"-        === toExp (enumFromThenToChoice 0 :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number -> Number"-        --| "```chooseFromTo x y z == [x | y .. z]```"-    ]--timeFunctions :: Map.Map Text AnnotatedExpression-timeFunctions =-  Map.unions-    [ "*"-        === toExp (flip fast :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)-        <:: "a -> Number -> a"-        --| "multiply time, making it faster",-      "fast"-        === toExp (fast :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "multiply time, making it faster",-      "/"-        === toExp (flip slow :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)-        <:: "a -> Number -> a"-        --| "divide time, making it slower",-      "slow"-        === toExp (slow :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "divide time, making it slower",-      "+"-        === toExp (flip shift :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)-        <:: "a -> Number -> a"-        --| "shift time to the right",-      "-"-        === toExp (flip (shift . fmap negate) :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)-        <:: "a -> Number -> a"-        --| "shift time to the left",-      "shift"-        === toExp (shift :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "shift time",-      "revBy"-        === toExp (revBy :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "reverse time, piecewise",-      "rev"-        === toExp (rev :: Zwirn Expression -> Zwirn Expression)-        <:: "a -> a"-        --| "reverse time completely",-      "ply"-        === toExp (ply :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "speed up time inside",-      "timeloop"-        === toExp (timeloop :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "loop time from 0 to the given number",-      "zoom"-        === toExp (zoom :: Zwirn Time -> Zwirn Time -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> Number -> a -> a"-        --| "zoom and loop a part of a zwirn"-    ]--structureFunctions :: Map.Map Text AnnotatedExpression-structureFunctions =-  Map.unions-    [ "euclidOff"-        === toExp (euclidOff :: Zwirn Int -> Zwirn Int -> Zwirn Int -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> Number -> Number -> a -> a"-        --| "shifted euclidean rhythm",-      "euclid"-        === toExp (euclid :: Zwirn Int -> Zwirn Int -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> Number -> a -> a"-        --| "euclidean rhythm",-      "segment"-        === toExp (segment :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "divide structure into equal pieces",-      "struct"-        === toExp (struct :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "a -> b -> b"-        --| "copy the structure from first value",-      "run"-        === toExp (run :: Zwirn Int -> Zwirn Int)-        <:: "Number -> Number"-        --| "```run n == [0 .. n-1]```",-      "runFromTo"-        === toExp (runFromTo :: Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number"-        --| "```runFromTo x y == [x .. y]```",-      "runFromThenTo"-        === toExp (runFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number -> Number"-        --| "```runFromTo x y z == [x y ..  z]```",-      "slowrun"-        === toExp (slowrun :: Zwirn Int -> Zwirn Int)-        <:: "Number -> Number"-        --| "```run n == <0 .. n-1>```",-      "slowrunFromTo"-        === toExp (slowrunFromTo :: Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number"-        --| "```slowrunFromTo x y == <x .. y>```",-      "slowrunFromThenTo"-        === toExp (slowrunFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number -> Number"-        --| "```slowrunFromTo x y z == <x y ..  z>```"-    ]--conditionalFunctions :: Map.Map Text AnnotatedExpression-conditionalFunctions =-  Map.unions-    [ "=="-        === toExp (eq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)-        <:: "Eq a => a -> a -> Number"-        --| "equality",-      ">="-        === toExp (geq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)-        <:: "Number -> Number -> Number"-        --| "greater or equal",-      "<="-        === toExp (leq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)-        <:: "Number -> Number -> Number"-        --| "less or equal",-      "<"-        === toExp (ge :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)-        <:: "Number -> Number -> Number"-        --| "less",-      ">"-        === toExp (le :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)-        <:: "Number -> Number -> Number"-        --| "greater",-      "not"-        === toExp (Z.not :: Zwirn Bool -> Zwirn Bool)-        <:: "Number -> Number"-        --| "logical not",-      "&&"-        === toExp (Z.and :: Zwirn Bool -> Zwirn Bool -> Zwirn Bool)-        <:: "Number -> Number -> Number"-        --| "logical and",-      "||"-        === toExp (Z.or :: Zwirn Bool -> Zwirn Bool -> Zwirn Bool)-        <:: "Number -> Number -> Number"-        --| "logical or",-      "ifthen"-        === toExp (ifthen :: Zwirn Bool -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a -> a"-        --| "choose between two expressions based on a condition",-      "if"-        === toExp (iff :: Zwirn Bool -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "if condition is true produce the value, silence otherwise",-      "while"-        === toExp (while :: Zwirn Bool -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> (a -> a) -> a -> a"-        --| "apply function while condition is true",-      "everyFor"-        === toExp (everyFor :: Zwirn Time -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> Number -> (a -> a) -> a -> a"-        --| "apply function periodically for a given amount of time",-      "every"-        === toExp (every :: Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> (a -> a) -> a -> a"-        --| "apply function periodically for one cycle"-    ]--cordFunctions :: Map.Map Text AnnotatedExpression-cordFunctions =-  Map.unions-    [ "project"-        === toExp (project :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "project to a certain layer of a cord",-      "insert"-        === toExp (C.insert :: Zwirn Int -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a -> a"-        --| "insert into a specific layer of a cord",-      "remove"-        === toExp (remove :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> a -> a"-        --| "remove a specific layer of a cord",-      "arp"-        === toExp (arp :: Zwirn Expression -> Zwirn Expression)-        <:: "a -> a"-        --| "arpeggiate",-      "reverse"-        === toExp (reverseC :: Zwirn Expression -> Zwirn Expression)-        <:: "a -> a"-        --| "reverse order of cord",-      "invert"-        === toExp (invertC :: Zwirn Expression -> Zwirn Expression)-        <:: "Number -> Number"-        --| "chord inversion",-      "rotate"-        === toExp (rotateC :: Zwirn Expression -> Zwirn Expression)-        <:: "a -> a"-        --| "cord rotation",-      "at"-        === toExp (at :: Zwirn Int -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)-        <:: "Number -> (a -> a) -> a -> a"-        --| "apply a function to a specific layer of a cord",-      "cordFromTo"-        === toExp (enumFromToStack :: Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number"-        --| "```cordFromTo x y == [x, .. y]```",-      "cordFromThenTo"-        === toExp (enumFromThenToStack :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)-        <:: "Number -> Number -> Number -> Number"-        --| "```cordFromThenTo x y z == [x, y .. z]```"-    ]--mapFunctions :: Map.Map Text AnnotatedExpression-mapFunctions =-  Map.unions-    [ "pN"-        === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Double -> Zwirn Expression)-        <:: "Text -> Number -> Map"-        --| "number singleton with specific key",-      "pT"-        === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Text -> Zwirn Expression)-        <:: "Text -> Text -> Map"-        --| "text singleton with specific key",-      "#"-        === toExp (union :: Zwirn ExpressionMap -> Zwirn ExpressionMap -> Zwirn ExpressionMap)-        <:: "Map -> Map -> Map"-        --| "union of two maps - structure from the left",-      "lookupN"-        === toExp (M.lookup :: Zwirn Text -> Zwirn ExpressionMap -> Zwirn Expression)-        <:: "Text -> Map -> Number"-        --| "retrieve number at given key or silence if key is missing or it's value not a number",-      "lookupT"-        === toExp (M.lookup :: Zwirn Text -> Zwirn ExpressionMap -> Zwirn Expression)-        <:: "Text -> Map -> Text"-        --| "retrieve text at given key or silence if key is missing or it's value not a text",-      "fix"-        === toExp (M.fix :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn ExpressionMap -> Zwirn ExpressionMap)-        <:: "Text -> (Map -> Map) -> 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",-      "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"-        --| ""-    ]--stateFunctions :: Map.Map Text AnnotatedExpression-stateFunctions =-  Map.unions-    [ "getN"-        === toExp getStateN-        <:: "Text -> Number"-        --| "retrieve number from state at given key or silence if key is missing or it's value not a number",-      "getT"-        === toExp getStateT-        <:: "Text -> Text"-        --| "retrieve text from state at given key or silence if key is missing or it's value not a text",-      "getM"-        === toExp getStateM-        <:: "Text -> Map"-        --| "retrieve map from state at given key or silence if key is missing or it's value not a map",-      "set"-        === toExp setState-        <:: "Text -> a -> b -> b"-        --| "set state at key to given value",-      "modify"-        === toExp modifyState-        <:: "Text -> (a -> a) -> b -> b"-        --| "modify state at given key with function"-    ]
− src/Zwirn/Language/Compiler.hs 
@@ -1,425 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}--module Zwirn.Language.Compiler where--{--    Compiler.hs - implementation of a compiler-interpreter for zwirn-    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 Control.Concurrent (readMVar)-import Control.Exception (SomeException, try)-import Control.Monad-import Control.Monad.Except-import Control.Monad.State-import Data.List (sortOn)-import Data.Text (Text, unpack)-import Data.Text.IO (readFile)-import Text.Read (readMaybe)-import Zwirn.Core.Types (silence)-import Zwirn.Language.Block-import Zwirn.Language.Builtin.Prelude (builtinNames)-import Zwirn.Language.Environment-import Zwirn.Language.Evaluate-import Zwirn.Language.Parser-import Zwirn.Language.Pretty-import qualified Zwirn.Language.Rotate as R-import Zwirn.Language.Simple-import Zwirn.Language.Syntax-import Zwirn.Language.TypeCheck.Constraint (runSolve)-import Zwirn.Language.TypeCheck.Infer-import Zwirn.Language.TypeCheck.Types-import Zwirn.Stream-import Prelude hiding (readFile)--newtype CIMessage-  = CIMessage Text-  deriving (Show, Eq)--data CurrentBlock-  = CurrentBlock Int Int-  deriving (Eq, Show)--data ConfigEnv-  = ConfigEnv-  { cConfigPath :: IO String,-    cResetConfig :: IO String-  }--data CiConfig = CiConfig-  { ciConfigOverwriteBuiltin :: Bool,-    ciConfigDynamicTypes :: Bool-  }--data Environment-  = Environment-  { tStream :: Stream,-    intEnv :: InterpreterEnv,-    confEnv :: Maybe ConfigEnv,-    currBlock :: Maybe CurrentBlock,-    ciConfig :: CiConfig-  }--data CIError-  = CIError-  { eError :: String,-    eEnv :: Environment-  }--instance Show CIError where-  show (CIError err _) = err--type CI = StateT Environment (ExceptT CIError IO)--runCI :: Environment -> CI a -> IO (Either CIError a)-runCI env m = runExceptT $ evalStateT m env--compilerInterpreterBasic :: Text -> CI String-compilerInterpreterBasic input = do-  as <- runParser input-  runActions True as--compilerInterpreterBlock :: Int -> Int -> Text -> CI (String, Environment, Int, Int)-compilerInterpreterBlock line editor input = do-  blocks <- runBlocks 0 input-  (Block strt end content) <- runGetBlock line blocks-  setCurrentBlock strt end-  as <- runParserWithPos strt editor content-  r <- runActions True as-  e <- get-  return (r, e, strt, end)--compilerInterpreterLine :: Int -> Int -> Text -> CI (String, Environment, Int, Int)-compilerInterpreterLine line editor input = do-  setCurrentBlock line line-  blocks <- runBlocks 0 input-  content <- runGetLine line blocks-  as <- runParserWithPos line editor content-  r <- runActions True as-  e <- get-  return (r, e, line, line)--compilerInterpreterWhole :: Int -> Text -> CI (String, Environment, Int, Int)-compilerInterpreterWhole editor input = do-  blocks <- runBlocks 0 input-  let sorted = sortOn (\(Block x _ _) -> x) blocks-      (Block strt _ _) = head sorted-      (Block _ end _) = last sorted-  liftIO $ print sorted-  setCurrentBlock strt end-  let parseBlock (Block s _ c) = runParserWithPos s editor c-  ass <- mapM parseBlock sorted-  rs <- mapM (runActions True) ass-  e <- get-  return (last rs, e, strt, end)--compilerInterpreterBoot :: [Text] -> CI Environment-compilerInterpreterBoot ps = runActions False (map Load ps) >> get------------------------------------------------------------------------- Throwing Errors ---------------------------------------------------------------------------throw :: String -> CI a-throw err = do-  env <- get-  throwError $ CIError err env--setCurrentBlock :: Int -> Int -> CI ()-setCurrentBlock st en = modify (\env -> env {currBlock = Just $ CurrentBlock st en})------------------------------------------------------------------------------ Parser -------------------------------------------------------------------------------runParserWithPos :: Int -> Int -> Text -> CI [Action]-runParserWithPos ln ed t = case parseActionsWithPos ln ed t of-  Left err -> throw err-  Right as -> return as--runParser :: Text -> CI [Action]-runParser t = case parseActions t of-  Left err -> throw err-  Right as -> return as--runBlocks :: Int -> Text -> CI [Block]-runBlocks ln t = case parseBlocks ln t of-  Left err -> throw err-  Right bs -> return bs--runGetBlock :: Int -> [Block] -> CI Block-runGetBlock i bs = case getBlock i bs of-  Left err -> throw err-  Right b -> return b--runGetLine :: Int -> [Block] -> CI Text-runGetLine i bs = case getLn i bs of-  Left err -> throw err-  Right b -> return b------------------------------------------------------------------------------ Desugar ------------------------------------------------------------------------------runSimplify :: Term -> CI SimpleTerm-runSimplify t = return $ simplify t--runSimplifyDef :: Def -> CI SimpleDef-runSimplifyDef d = return $ simplifyDef d--------------------------------------------------------------------------- AST Rotation ----------------------------------------------------------------------------runRotate :: SimpleTerm -> CI SimpleTerm-runRotate s = case R.runRotate s of-  Left err -> throw err-  Right t -> return t---------------------------------------------------------------------------- Type Check -----------------------------------------------------------------------------runTypeCheck :: SimpleTerm -> CI Scheme-runTypeCheck s = do-  Environment {intEnv = env} <- get-  case inferTerm env s of-    Left err -> throw $ show err-    Right t -> return t---------------------------------------------------------------------------- Interpreter ----------------------------------------------------------------------------interpret :: SimpleTerm -> CI Expression-interpret input = do-  env <- gets intEnv-  return $ evaluate env input---- if ctx is false, highlighting should be disabled-checkHighlight :: Bool -> Expression -> CI Expression-checkHighlight True x = return x-checkHighlight False x = return $ removePosExp x------------------------------------------------------------------------- Compiling Actions -------------------------------------------------------------------------defAction :: Bool -> Def -> CI ()-defAction ctx d = do-  (LetS x st) <- runSimplifyDef d-  rot <- runRotate st-  ty@(Forall _ (Qual _ typ)) <- runTypeCheck rot-  ex <- interpret rot-  exCtx <- checkHighlight ctx ex-  dynamic <- gets (ciConfigDynamicTypes . ciConfig)--  if dynamic-    then checkAndDefine x ty exCtx-    else do-      mayty <- gets (lookupType x . intEnv)-      case mayty of-        Just (Forall _ (Qual _ oldType)) -> case runSolve [(oldType, typ)] of-          Left _ -> throw "Cannot overwrite definition with new type. Please use DynamicTypes."-          Right _ -> checkAndDefine x ty exCtx-        Nothing -> checkAndDefine x ty exCtx--checkAndDefine :: Text -> Scheme -> Expression -> CI ()-checkAndDefine x ty exCtx = do-  overwrite <- gets (ciConfigOverwriteBuiltin . ciConfig)-  if overwrite-    then modify (\env -> env {intEnv = extend (x, exCtx, ty) (intEnv env)})-    else-      if x `elem` builtinNames-        then throw "Failed to overwrite builtin function. Please enable OverwriteBuiltin."-        else modify (\env -> env {intEnv = extend (x, exCtx, ty) (intEnv env)})--showAction :: Term -> CI String-showAction t = do-  s <- runSimplify t-  rot <- runRotate s-  ty <- runTypeCheck rot-  if isBasicType ty-    then do-      ex <- interpret rot-      stmv <- gets (sState . tStream)-      st <- liftIO $ readMVar stmv-      return $ showWithState st ex-    else throw $ "Can not show expressions of type: " ++ ppscheme ty--typeAction :: Term -> CI String-typeAction t = do-  s <- runSimplify t-  rot <- runRotate s-  ty <- runTypeCheck rot-  return $ ppTermHasType (t, ty)--loadAction :: Text -> CI ()-loadAction path = do-  mayfile <- liftIO ((try $ readFile $ unpack path) :: IO (Either SomeException Text))-  case mayfile of-    Left _ -> throw "file not found"-    Right input -> do-      blocks <- runBlocks 0 input-      let sorted = sortOn (\(Block x _ _) -> x) blocks-      ass <- mapM (runParser . bContent) sorted-      mapM_ (runActions False) ass--infoAction :: Text -> CI String-infoAction n = do-  env <- gets intEnv-  case lookupFull n env of-    Just (Annotated _ t (Just d)) -> return $ unpack n ++ " :: " ++ ppscheme t ++ "\n" ++ unpack d-    Just (Annotated _ t Nothing) -> return $ unpack n ++ " :: " ++ ppscheme t-    Nothing -> throw $ "couldn't find information about " ++ unpack n--streamAction :: Bool -> Text -> Term -> CI ()-streamAction ctx key t = do-  s <- runSimplify t-  rot <- runRotate s-  ty <- runTypeCheck rot-  ex <- interpret rot-  exCtx <- checkHighlight ctx ex-  if isBasicType ty-    then-      ( do-          str <- gets tStream-          liftIO $ streamReplace str key (fromExp exCtx)-      )-    else-      if isBus ty-        then-          ( do-              str <- gets tStream-              let mayindex = readMaybe $ unpack key-              case mayindex of-                Just ind -> liftIO $ streamReplaceBus str ind (fromExp exCtx)-                Nothing -> throw "Please use an integer as bus index."-          )-        else throw "Can only stream base types!"--streamSetAction :: Bool -> Text -> Term -> CI ()-streamSetAction ctx x t = do-  s <- runSimplify t-  rot <- runRotate s-  ty@(Forall _ (Qual _ typ)) <- runTypeCheck rot-  ex <- interpret rot-  exCtx <- checkHighlight ctx ex--  dynamic <- gets (ciConfigDynamicTypes . ciConfig)--  if dynamic-    then checkAndSet x ty exCtx-    else do-      mayty <- gets (lookupType x . intEnv)-      case mayty of-        Just (Forall _ (Qual _ oldType)) -> case runSolve [(oldType, typ)] of-          Left _ -> throw "Cannot overwrite definition with new type. Please use DynamicTypes."-          Right _ -> checkAndSet x ty exCtx-        Nothing -> checkAndSet x ty exCtx--checkAndSet :: Text -> Scheme -> Expression -> CI ()-checkAndSet x ty exCtx =-  if isBasicType ty-    then-      ( do-          overwrite <- gets (ciConfigOverwriteBuiltin . ciConfig)-          if overwrite-            then setExpression x ty exCtx-            else-              if x `elem` builtinNames-                then throw "Failed to overwrite builtin function. Please enable OverwriteBuiltin."-                else setExpression x ty exCtx-      )-    else throw "Can only set basic types!"--setExpression :: Text -> Scheme -> Expression -> CI ()-setExpression x ty exCtx = do-  modify (\env -> env {intEnv = extend (x, newEx, ty) (intEnv env)})-  str <- gets tStream-  liftIO $ streamSet str x exCtx-  where-    newEx-      | isNumberT ty = EZwirn $ getStateN (pure x)-      | isTextT ty = EZwirn $ getStateT (pure x)-      | isMapT ty = EZwirn $ getStateM (pure x)-      | otherwise = EZwirn silence--streamOnceAction :: Bool -> Term -> CI ()-streamOnceAction ctx t = do-  s <- runSimplify t-  rot <- runRotate s-  ty <- runTypeCheck rot-  ex <- interpret rot-  exCtx <- checkHighlight ctx ex-  if isBasicType ty-    then-      ( do-          str <- gets tStream-          liftIO $ streamFirst str (fromExp exCtx)-      )-    else throw "Can only stream base types!"--streamSetTempoAction :: Tempo -> Text -> CI ()-streamSetTempoAction CPS t = gets tStream >>= \str -> liftIO $ streamSetCPS str (toRational (read $ unpack t :: Double))-streamSetTempoAction BPM t = gets tStream >>= \str -> liftIO $ streamSetBPM str (toRational (read $ unpack t :: Double))--resetConfigAction :: CI String-resetConfigAction = do-  (Environment {confEnv = mayEnv}) <- get-  case mayEnv of-    Nothing -> throw "Configuration not available."-    Just (ConfigEnv _ reset) -> liftIO reset--getConfigPathAction :: CI String-getConfigPathAction = do-  (Environment {confEnv = mayEnv}) <- get-  case mayEnv of-    Nothing -> throw "Configuration not available."-    Just (ConfigEnv path _) -> liftIO path--runAction :: Bool -> Action -> CI String-runAction b (StreamAction i t) = streamAction b i t >> return ""-runAction b (StreamSet i t) = streamSetAction b i t >> return ""-runAction b (StreamOnce t) = streamOnceAction b t >> return ""-runAction _ (StreamSetTempo mode t) = streamSetTempoAction mode t >> return ""-runAction _ (Show t) = showAction t-runAction b (Def d) = defAction b d >> return ""-runAction _ (Type t) = typeAction t-runAction _ (Load p) = loadAction p >> return ""-runAction _ (Info p) = infoAction p-runAction _ ConfigPath = getConfigPathAction-runAction _ ResetConfig = resetConfigAction--runActions :: Bool -> [Action] -> CI String-runActions b as = last <$> mapM (runAction b) as--isNumberT :: Scheme -> Bool-isNumberT (Forall _ (Qual _ (TypeCon "Number"))) = True-isNumberT _ = False--isTextT :: Scheme -> Bool-isTextT (Forall _ (Qual _ (TypeCon "Text"))) = True-isTextT _ = False--isMapT :: Scheme -> Bool-isMapT (Forall _ (Qual _ (TypeCon "Map"))) = True-isMapT _ = False
− src/Zwirn/Language/Environment.hs 
@@ -1,44 +0,0 @@-module Zwirn.Language.Environment where--import qualified Data.Map as Map-import Data.Text (Text)-import Zwirn.Core.Types (silence)-import Zwirn.Language.Evaluate.Expression-import Zwirn.Language.TypeCheck.Types--data AnnotatedExpression-  = Annotated-  { aExp :: Expression,-    aType :: Scheme,-    aDesc :: Maybe Text-  }--data InterpreterEnv = IEnv-  { eExpressions :: Map.Map Text AnnotatedExpression,-    eInstances :: [Instance]-  }--withExpressions :: (Map.Map Text AnnotatedExpression -> Map.Map Text AnnotatedExpression) -> InterpreterEnv -> InterpreterEnv-withExpressions f (IEnv l i) = IEnv (f l) i--extend :: (Text, Expression, Scheme) -> InterpreterEnv -> InterpreterEnv-extend (n, x, s) = withExpressions (Map.insert n (Annotated x s Nothing))--lookupType :: Text -> InterpreterEnv -> Maybe Scheme-lookupType k (IEnv l _) = aType <$> Map.lookup k l--insertType :: Text -> Scheme -> InterpreterEnv -> InterpreterEnv-insertType t s = withExpressions (Map.alter alt t)-  where-    dummy = EZwirn silence-    alt Nothing = Just $ Annotated dummy s Nothing-    alt (Just (Annotated x _ i)) = Just $ Annotated x s i--lookupDescription :: Text -> InterpreterEnv -> Maybe Text-lookupDescription k (IEnv l _) = aDesc =<< Map.lookup k l--lookupExp :: Text -> InterpreterEnv -> Maybe Expression-lookupExp k (IEnv l _) = aExp <$> Map.lookup k l--lookupFull :: Text -> InterpreterEnv -> Maybe AnnotatedExpression-lookupFull k (IEnv l _) = Map.lookup k l
− src/Zwirn/Language/Evaluate.hs 
@@ -1,12 +0,0 @@-module Zwirn.Language.Evaluate-  ( module Zwirn.Language.Evaluate.Expression,-    module Zwirn.Language.Evaluate.Internal,-    module Zwirn.Language.Evaluate.Convert,-    module Zwirn.Language.Evaluate.SKI,-  )-where--import Zwirn.Language.Evaluate.Convert-import Zwirn.Language.Evaluate.Expression-import Zwirn.Language.Evaluate.Internal-import Zwirn.Language.Evaluate.SKI
− src/Zwirn/Language/Evaluate/Convert.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}--module Zwirn.Language.Evaluate.Convert where--{--    Convert.hs - convert from and to Expressions-    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 qualified Data.Map as Map-import Data.String (IsString, fromString)-import Data.Text (Text, pack)-import Zwirn.Core.Time (Time (..))-import Zwirn.Core.Types-import Zwirn.Language.Evaluate.Expression--fromZwirn :: Zwirn Expression -> Expression-fromZwirn = EZwirn--toZwirn :: Expression -> Zwirn Expression-toZwirn (EZwirn x) = x-toZwirn _ = silence--class FromExpression a where-  fromExp :: Expression -> Zwirn a--class ToExpression a where-  toExp :: a -> Expression--instance FromExpression Time where-  fromExp (EZwirn tz) = fmap (\(ENum t) -> Time (toRational t) 0) tz-  fromExp _ = silence--instance FromExpression Double where-  fromExp (EZwirn tz) = fmap (\(ENum t) -> t) tz-  fromExp _ = silence--instance FromExpression Int where-  fromExp (EZwirn tz) = fmap (\(ENum t) -> floor t) tz-  fromExp _ = silence--instance FromExpression Expression where-  fromExp (EZwirn z) = z-  fromExp _ = silence--instance FromExpression Text where-  fromExp (EZwirn z) = fmap (\(EText t) -> t) z-  fromExp _ = silence--instance FromExpression Bool where-  fromExp (EZwirn z) = fmap (\(ENum x) -> x >= 1) z-  fromExp _ = silence--instance FromExpression ExpressionMap where-  fromExp (EZwirn z) = fmap (\(EMap m) -> m) z-  fromExp _ = silence--instance (ToExpression a, FromExpression b) => FromExpression (Zwirn a -> Zwirn b) where-  fromExp (EZwirn z) = fmap (\(ELam f) -> fromExp . f . toExp) z-  fromExp _ = silence--instance (FromExpression a) => FromExpression (Zwirn a) where-  fromExp (EZwirn z) = fmap fromExp z-  fromExp _ = silence--instance ToExpression Expression where-  toExp = id--instance ToExpression Double where-  toExp = ENum--instance ToExpression Time where-  toExp (Time t _) = ENum $ fromRational t--instance ToExpression Int where-  toExp i = ENum $ fromIntegral i--instance ToExpression Bool where-  toExp True = ENum 1-  toExp False = ENum 0--instance ToExpression Text where-  toExp = EText--instance (ToExpression a) => ToExpression (Map.Map Text a) where-  toExp m = EMap $ toExp <$> m--instance (ToExpression a) => ToExpression (Zwirn a) where-  toExp a = EZwirn $ fmap toExp a--instance (FromExpression a, ToExpression b) => ToExpression (Zwirn a -> b) where-  toExp f = lambda $ \x -> toExp $ f (fromExp x)--instance Num Expression where-  (+) = pervasive2 ((+) @Double)-  (*) = pervasive2 ((*) @Double)-  abs = pervasive (abs @Double)-  signum = pervasive (signum @Double)-  fromInteger i = ENum $ fromInteger i-  negate = pervasive (negate @Double)--instance Fractional Expression where-  fromRational r = ENum $ fromRational r-  (/) = pervasive2 ((/) @Double)--instance Floating Expression where-  pi = EZwirn $ pure $ ENum pi-  exp = pervasive (exp :: Double -> Double)-  log = pervasive (log :: Double -> Double)-  sin = pervasive (sin :: Double -> Double)-  cos = pervasive (cos :: Double -> Double)-  asin = pervasive (asin :: Double -> Double)-  acos = pervasive (acos :: Double -> Double)-  atan = pervasive (atan :: Double -> Double)-  sinh = pervasive (sinh :: Double -> Double)-  cosh = pervasive (cosh :: Double -> Double)-  asinh = pervasive (asinh :: Double -> Double)-  acosh = pervasive (acosh :: Double -> Double)-  atanh = pervasive (atanh :: Double -> Double)--instance IsString Expression where-  fromString = EText . pack--class Pervasive a where-  pervasive :: (a -> a) -> Expression -> Expression-  pervasive2 :: (a -> a -> a) -> Expression -> Expression -> Expression--instance Pervasive Double where-  pervasive f (ENum d) = ENum $ f d-  pervasive f (EMap m) = EMap $ fmap (pervasive f) m-  pervasive _ e = e-  pervasive2 f (ENum d) (ENum e) = ENum $ f d e-  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n-  pervasive2 _ e _ = e--instance Pervasive Bool where-  pervasive f (ENum d) = toExp $ f (d >= 1)-  pervasive f (EMap m) = EMap $ fmap (pervasive f) m-  pervasive _ e = e-  pervasive2 f (ENum d) (ENum e) = toExp $ f (d >= 1) (e >= 1)-  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n-  pervasive2 _ e _ = e--instance Pervasive Text where-  pervasive f (EText d) = EText $ f d-  pervasive f (EMap m) = EMap $ fmap (pervasive f) m-  pervasive _ e = e-  pervasive2 f (EText d) (EText e) = EText $ f d e-  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n-  pervasive2 _ e _ = e--instance Pervasive (Either Double Text) where-  pervasive f (EText d) = EText $ (\(Right t) -> t) $ f (Right d)-  pervasive f (ENum d) = ENum $ (\(Left t) -> t) $ f (Left d)-  pervasive f (EMap m) = EMap $ fmap (pervasive f) m-  pervasive _ e = e-  pervasive2 f (EText d) (EText e) = EText $ (\(Right t) -> t) $ f (Right d) (Right e)-  pervasive2 f (ENum d) (ENum e) = ENum $ (\(Left t) -> t) $ f (Left d) (Left e)-  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n-  pervasive2 _ e _ = e
− src/Zwirn/Language/Evaluate/Expression.hs 
@@ -1,74 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}--module Zwirn.Language.Evaluate.Expression where--{--    Expression.hs - Abstract Expressions-    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 Data.List-import qualified Data.Map as Map-import Data.Text (Text, unpack)-import Zwirn.Core.Cord-import Zwirn.Core.Query-import Zwirn.Core.Time (Time (..))-import Zwirn.Language.Syntax-import Zwirn.Language.TypeCheck.Types--type ExpressionMap = Map.Map Text Expression--type Zwirn = Cord ExpressionMap Position--data Expression-  = EVar (Maybe Position) Name-  | EApp Expression Expression-  | ELam (Expression -> Expression)-  | ENum Double-  | EText Text-  | EMap ExpressionMap-  | ESeq [Expression]-  | EStack [Expression]-  | EChoice Int [Expression]-  | EZwirn (Zwirn Expression)--showWithState :: ExpressionMap -> Expression -> String-showWithState st (EZwirn x) = intercalate "\n" $ (\(t, y) -> show t ++ ":" ++ showWithState st y) <$> findAllValuesWithTime (Time 0 1, Time 1 1) st x-showWithState _ (ENum x) = take 5 $ show x-showWithState _ (EText x) = unpack x-showWithState st (EMap m) = show $ Map.toList $ showWithState st <$> m-showWithState _ _ = "can't show"--instance Show Expression where-  show = showWithState Map.empty--instance Eq Expression where-  (==) (ENum n) (ENum m) = n == m-  (==) (EText n) (EText m) = n == m-  (==) (EMap n) (EMap m) = n == m-  (==) _ _ = False--instance Ord Expression where-  (<=) (ENum n) (ENum m) = n <= m-  (<=) _ _ = False--lambda :: (Expression -> Expression) -> Expression-lambda f = EZwirn $ pure $ ELam f
− src/Zwirn/Language/Evaluate/Internal.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}--module Zwirn.Language.Evaluate.Internal where--{--    Internal.hs - internal functions, specific to Expressions-    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 qualified Data.Map as Map-import Data.Text (Text, pack)-import Zwirn.Core.Core (withState, (<$$>))-import Zwirn.Core.Map-import Zwirn.Core.State-import Zwirn.Core.Types-import Zwirn.Language.Evaluate.Convert-import Zwirn.Language.Evaluate.Expression---- helper--insert :: (Text, Expression) -> ExpressionMap -> ExpressionMap-insert (k, x) = Map.insert k x--getStateN :: Zwirn Text -> Zwirn Expression-getStateN xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))-  where-    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromNum x-    fromLookup _ = silence-    fromNum (ENum n) = pure $ ENum n-    fromNum _ = silence--getStateT :: Zwirn Text -> Zwirn Expression-getStateT xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))-  where-    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromText x-    fromLookup _ = silence-    fromText (EText n) = pure $ EText n-    fromText _ = silence--getStateM :: Zwirn Text -> Zwirn Expression-getStateM xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))-  where-    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromMap x-    fromLookup _ = silence-    fromMap (EMap n) = pure $ EMap n-    fromMap _ = silence--modifyState :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression-modifyState kz fz xz = modifyState' <$> kz <*> fz <$$> xz-  where-    modifyState' :: Text -> (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression-    modifyState' key f = withState (Map.update (Just . toExp . f . fromExp) key)--setState :: Zwirn Text -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression-setState t x = setMap t (pure $ EZwirn x)--recv :: Zwirn Text -> Zwirn Int -> Zwirn ExpressionMap-recv t i = singleton t (fmap (toExp . (\x -> pack $ "c" ++ show x)) i)
− src/Zwirn/Language/Evaluate/SKI.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# OPTIONS_GHC -Wno-unused-top-binds #-}--module Zwirn.Language.Evaluate.SKI-  ( evaluate,-    (!),-    removePosExp,-  )-where--{--    SKI.hs - evaluate epxressions via the SKI combinator calculus,-    code adapted from https://kseo.github.io/posts/2016-12-30-write-you-an-interpreter.html-    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 Data.Maybe (fromJust)-import Data.Text (unpack)-import Zwirn.Core.Cord-import Zwirn.Core.Core-import Zwirn.Core.Modulate-import Zwirn.Core.Random (chooseWithSeed)-import Zwirn.Core.Types-import Zwirn.Language.Environment-import Zwirn.Language.Evaluate.Convert-import Zwirn.Language.Evaluate.Expression-import Zwirn.Language.Simple-import Zwirn.Language.TypeCheck.Types--compile :: SimpleTerm -> Expression-compile (SVar p n) = EVar p n-compile (SApp fun arg) = EApp (compile fun) (compile arg)-compile (SLambda x body) = abstract x (compile body)-compile (SNum (Just p) x) = EZwirn $ addInfo p $ pure $ ENum $ read $ unpack x-compile (SNum Nothing x) = EZwirn $ pure $ ENum $ read $ unpack x-compile (SText p x) = EZwirn $ addInfo p $ pure $ EText x-compile (SSeq xs) = ESeq $ map compile xs-compile (SStack xs) = EStack $ map compile xs-compile (SChoice i xs) = EChoice i $ map compile xs-compile (SInfix s1 n s2) = EApp (EApp (EVar Nothing n) (compile s1)) (compile s2)-compile (SBracket s) = compile s-compile SRest = EZwirn silence--abstract :: Name -> Expression -> Expression-abstract x (EVar _ n) | x == n = combI-abstract x (EApp fun arg) = combS (abstract x fun) (abstract x arg)-abstract x (ESeq xs) = ESeq $ map (abstract x) xs-abstract x (EStack xs) = EStack $ map (abstract x) xs-abstract x (EChoice i xs) = EChoice i $ map (abstract x) xs-abstract _ k = combK k--combS :: Expression -> Expression -> Expression-combS f = EApp (EApp (EVar Nothing "scomb") f)--combK :: Expression -> Expression-combK = EApp (EVar Nothing "const")--combI :: Expression-combI = EVar Nothing "id"--infixl 0 !--(!) :: Expression -> Expression -> Expression-(EZwirn fp) ! (EZwirn x) = EZwirn $ squeezeApply (fmap (\(ELam f) -> toZwirn . f . fromZwirn) fp) x-_ ! _ = error "Error in (!)"--link :: InterpreterEnv -> Expression -> Expression-link bs (EVar (Just p) n) = addPosExp p $ fromJust (lookupExp n bs)-link bs (EVar Nothing n) = fromJust (lookupExp n bs)-link bs (EApp f x) = link bs f ! link bs x-link bs (ESeq xs) = EZwirn $ fastcat $ map (toZwirn . link bs) xs-link bs (EStack xs) = EZwirn $ stack $ map (toZwirn . link bs) xs-link bs (EChoice i xs) = EZwirn $ chooseWithSeed i $ map (toZwirn . link bs) xs-link _ e = e--evaluate :: InterpreterEnv -> SimpleTerm -> Expression-evaluate bs = link bs . compile--addPosExp :: Position -> Expression -> Expression-addPosExp p (EZwirn x) = EZwirn $ withInfos (p :) x-addPosExp _ x = x--removePosExp :: Expression -> Expression-removePosExp (EZwirn z) = EZwirn $ removeInfo z-removePosExp x = x
− src/Zwirn/Language/Lexer.x 
@@ -1,395 +0,0 @@-{-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}-module Zwirn.Language.Lexer-  ( -- * Invoking Alex-    Alex-  , AlexPosn (..)-  , alexGetInput-  , alexError-  , runAlex-  , alexMonadScan--  , Range (..)-  , RangedToken (..)-  , Token (..)-  , scanMany-  , increaseChoice-  , setEditorNum-  , getEditorNum-  , setInitialLineNum-  , lineLexer-  , typeLexer-  ) where--{--    Lexer.hs - lexer for zwirn, code adapted from-    https://serokell.io/blog/lexing-with-alex-    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           Data.Text (Text)-import qualified Data.Text as Text-import Control.Monad (when)-}--%wrapper "monadUserState-strict-text"--$digit = [0-9]-$alphasmall = [a-z]-$alpha = [a-zA-Z]--@id = ($alphasmall) ($alpha | $digit | \_ )*-@singles = ("&" | "$" | "?" | "#" | "." | "^")-@otherops = ("|" | "=" | "~" | "<" | ">" | "%")-@specialop = ("*" | "/" | "'" | "+" | "-")-@op = ((@singles (@singles | @otherops | @specialop)*) | ((@otherops | @specialop) (@singles | @otherops | @specialop)+))-@num = ("-")? ($digit)+ ("." ($digit)+)?-@path = $white ($alpha | "/" | ".")+--tokens :---<0> $white+ ;--<line> (.+ (\n?) | \n)               { mkLine }--<ty> $white+ ;-<ty> $alpha+ "." ;-<ty> "=>"                          { tok Context }-<ty> "->"                          { tok Arrow }-<ty> "("                           { tok LPar }-<ty> ")"                           { tok RPar }-<ty> ","                           { tok Comma }-<ty> "Text"                        { tok TextToken }-<ty> "Number"                      { tok NumberToken }-<ty> "Map"                         { tok MapToken }-<ty> "Bus"                         { tok BusToken }-<ty> @id                           { tokText VarToken }-<ty> [A-Z] $alphasmall+            { tokText TypeClass }-<ty> @id                           { tokText Identifier }-<ty> @op                           { tokText Operator }-<ty> @specialop                    { tokText SpecialOp }---- Multi Line Comments--<0>       "{-" { nestComment `andBegin` comment }-<0>       "-}" { \_ _ -> alexError "Error: unexpected closing comment" }-<comment> "{-" { nestComment }-<comment> "-}" { unnestComment }-<comment> .    ;-<comment> \n   ;---- Single Line Comments--<0> "--" .* ;---- Repeat-<0> "!"               { tok Repeat }-<0> "!"($digit+)      { tokText (\t -> RepeatNum $ Text.drop 1 t) }---- Parenthesis-<0> "("     { tok LPar }-<0> ")"     { tok RPar }---- Sequences-<0> "["     { tok LBrack }-<0> "]"     { tok RBrack }---- Stacks-<0> ","     { tok Comma }---- Choice-<0> "|"     { tok Pipe }---- Enum-<0> ".."    { tok Enum }---- Polyrhythm-<0> "%"     { tok Poly }---- Euclid-<0> "{"     { tok LBraces }-<0> "}"     { tok RBraces }---- Lambda-<0> "\"     { tok Lambda }-<0> "->"    { tok Arrow }---- Actions-<0> ";"                               { tok Colon }-<0> "<-"                              { tok StreamA }-<0> ":cps"                            { tok TempoCps }-<0> ":bpm"                            { tok TempoBpm }-<0> ":t"                              { tok TypeA }-<0> "="                               { tok Assign }-<0> ":show"                           { tok ShowA }-<0> ":config"                         { tok ConfigA }-<0> ":resetconfig"                    { tok ResetConfigA }-<0> ":info"                           { tok InfoA }-<0> (":load") @path                   { tokText (\t -> LoadA $ Text.drop 6 t) }---- Identifiers-<0> @id             { tokText Identifier }---- Operator Identifier-<0> \( @op \)       { tokText (Identifier . rmFirstLast) }---- Constants-<0> @num            { tokText Number }-<0> \"[^\"]*\"      { tokText String }-<0> "~"             { tok Rest }---- Operators-<0> @op             { tokText Operator }-<0> @specialop      { tokText SpecialOp }---- Alternations-<0> "<"     { tok LAngle }-<0> ">"     { tok RAngle }--{-data AlexUserState = AlexUserState-  { nestLevel :: Int-  , choiceNum :: Int-  , editorNum :: Int-  }--alexInitUserState :: AlexUserState-alexInitUserState = AlexUserState { nestLevel = 0, choiceNum = 0, editorNum = 0}--get :: Alex AlexUserState-get = Alex $ \s -> Right (s, alex_ust s)--put :: AlexUserState -> Alex ()-put s' = Alex $ \s -> Right (s{alex_ust = s'}, ())--modify :: (AlexUserState -> AlexUserState) -> Alex ()-modify f = Alex $ \s -> Right (s{alex_ust = f (alex_ust s)}, ())--alexEOF :: Alex RangedToken-alexEOF = do-  startCode <- alexGetStartCode-  when (startCode == comment) $-    alexError "Error: unclosed comment"-  (pos, _, _, _) <- alexGetInput-  pure $ RangedToken EOF (Range pos pos)--data Range = Range-  { start :: AlexPosn-  , stop :: AlexPosn-  } deriving (Eq, Show)--data RangedToken = RangedToken-  { rtToken :: Token-  , rtRange :: Range-  } deriving (Eq, Show)--data Token-  -- Identifiers-  = Identifier Text-  -- Constants-  | String Text-  | Number Text-  | Rest-  -- Operators-  | Operator Text-  | SpecialOp Text-  -- Repeat-  | Repeat-  | RepeatNum Text-  -- Parenthesis-  | LPar-  | RPar-  -- Sequences-  | LBrack-  | RBrack-  -- Stacks-  | Comma-  -- Alternations-  | LAngle-  | RAngle-  -- Choice-  | Pipe-  -- Polyrhythm-  | Poly-  -- Euclid-  | LBraces-  | RBraces-  -- Lambda-  | Lambda-  | Arrow-  -- Enum-  | Enum-  -- Actions-  | Colon-  | StreamA-  | TempoCps-  | TempoBpm-  | TypeA-  | ShowA-  | ConfigA-  | ResetConfigA-  | Assign-  | LoadA Text-  | InfoA-  -- Line & Block Tokens-  | LineT Text-  | BlockSep-  -- Type Tokens-  | Context-  | TextToken-  | NumberToken-  | MapToken-  | BusToken-  | VarToken Text-  | TypeClass Text-  -- EOF-  | EOF-  deriving (Eq)--instance Show Token where- show (Identifier s) = show s- show (String s) = show s- show (Number d) = show d- show Rest = quoted "~"- show (Operator o) = show o- show (SpecialOp o) = show o- show Repeat = quoted "!"- show (RepeatNum x) = quoted "!" ++ show x- show LPar = quoted "("- show RPar = quoted ")"- show LBrack = quoted "["- show RBrack = quoted "]"- show Comma = quoted ","- show LAngle = quoted "<"- show RAngle = quoted ">"- show Pipe = quoted "|"- show Poly = quoted "%"- show LBraces = quoted "{"- show RBraces = quoted "}"- show Lambda = quoted "\\"- show Arrow = quoted "->"- show Colon = quoted ";"- show Enum = quoted ".."- show StreamA = quoted "<-"- show TempoCps = ":cps"- show TempoBpm = ":bpm"- show TypeA = quoted ":t"- show ShowA = quoted ":show"- show ConfigA = quoted ":config"- show ResetConfigA = quoted ":resetconfig"- show Assign = quoted "="- show (LoadA x) = ":load " <> show x- show InfoA = quoted ":info"- show (LineT t) = "line " <> show t- show BlockSep = "block"- show Context = "=>"- show TextToken = "Text"- show NumberToken = "Number"- show MapToken = "Map"- show BusToken = "Bus"- show (VarToken t) = show t- show (TypeClass c) = show c- show EOF = "end of file"--quoted :: String -> String-quoted s = "'" ++ s ++ "'"--mkRange :: AlexInput -> Int -> Range-mkRange (st, _, _, str) len = Range{start = st, stop = end}-  where-    end = Text.foldl' alexMove st $ Text.take len str--mkLine :: AlexAction RangedToken-mkLine inp@(_, _, _, str) len = case Text.all (\c -> elem c ("\n\t " :: String)) (Text.take len str) of-                            True -> tok BlockSep inp len-                            False -> pure RangedToken-                              { rtToken = LineT $ Text.map replaceTab (Text.take len str)-                              , rtRange = mkRange inp len-                              }---- | replace all tabs with a single space, since codemirror sees tabs as one column-replaceTab :: Char  -> Char-replaceTab '\t' = ' '-replaceTab x = x--rmFirstLast :: Text -> Text-rmFirstLast t = Text.init (Text.tail t)--tok :: Token -> AlexAction RangedToken-tok ctor inp len =-  pure RangedToken-    { rtToken = ctor-    , rtRange = mkRange inp len-    }--tokText :: (Text -> Token) -> AlexAction RangedToken-tokText f inp@(_, _, _, str) len =-  pure RangedToken-    { rtToken = f $ Text.take len str-    , rtRange = mkRange inp len-    }--nestComment :: AlexAction RangedToken-nestComment input len = do-  modify $ \s -> s{nestLevel = nestLevel s + 1}-  skip input len--unnestComment :: AlexAction RangedToken-unnestComment input len = do-  state <- get-  let level = nestLevel state - 1-  put state{nestLevel = level}-  when (level == 0) $-    alexSetStartCode 0-  skip input len--increaseChoice :: Alex Int-increaseChoice = do-  (AlexUserState c x e) <- get-  put $ AlexUserState c (x+1) e-  return x--getEditorNum :: Alex Int-getEditorNum = do-  (AlexUserState _ _ e) <- get-  return e--setEditorNum :: Int -> Alex ()-setEditorNum i = do-  (AlexUserState c x _) <- get-  put $ AlexUserState c x i--setInitialLineNum :: Int -> Alex ()-setInitialLineNum i = Alex alex-                    where alex s = Right (s {alex_pos = AlexPn x i c }, ())-                                 where AlexPn x _ c = alex_pos s--lineLexer :: Alex ()-lineLexer = alexSetStartCode line--typeLexer :: Alex ()-typeLexer = alexSetStartCode ty--scanMany :: Text -> Either String [RangedToken]-scanMany input = runAlex input go-  where-    go = do-      output <- lineLexer >> alexMonadScan-      if rtToken output == EOF-        then pure [output]-        else ((output) :) <$> go-}
− src/Zwirn/Language/Parser.y 
@@ -1,375 +0,0 @@-{-{-# LANGUAGE OverloadedStrings #-}-module Zwirn.Language.Parser-    ( parseActionsWithPos-    , parseActions-    , parseBlocks-    , parseScheme-    ) where--import           Data.Text (Text)-import qualified Data.Text as Text-import Data.Maybe (fromJust)-import Data.Monoid (First (..))-import Data.List (intercalate, sortOn)--import qualified Zwirn.Language.Lexer as L-import Zwirn.Language.Syntax-import Zwirn.Language.TypeCheck.Types-import Zwirn.Language.TypeCheck.Infer-import Zwirn.Language.Block--{--    Parser.hs - parser for zwirn, code adapted from-    https://serokell.io/blog/parsing-with-happy-    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/>.--}---}--%name parse term-%name pActions actions-%name pBlocks blocks-%name pScheme scheme-%tokentype { L.RangedToken }-%errorhandlertype explist-%error { parseError }-%monad { L.Alex } { >>= } { pure }-%lexer { lexer } { L.RangedToken L.EOF _ }-%expect 0--%token-  -- Identifiers-  identifier      { L.RangedToken (L.Identifier _) _ }-  -- Operators-  operator        { L.RangedToken (L.Operator _) _ }-  specop          { L.RangedToken (L.SpecialOp _) _ }-  -- Constants-  string          { L.RangedToken (L.String _) _ }-  number          { L.RangedToken (L.Number _) _ }-  line            { L.RangedToken (L.LineT _) _ }-  bsep            { L.RangedToken (L.BlockSep) _ }-  '~'             { L.RangedToken L.Rest _ }-  -- Repeat-  '!'             { L.RangedToken L.Repeat _ }-  repnum          { L.RangedToken (L.RepeatNum _) _}-  -- Parenthesis-  '('             { L.RangedToken L.LPar _ }-  ')'             { L.RangedToken L.RPar _ }-  -- Sequences-  '['             { L.RangedToken L.LBrack _ }-  ']'             { L.RangedToken L.RBrack _ }-  -- Stacks-  ','             { L.RangedToken L.Comma _ }-  -- Alternations-  '<'             { L.RangedToken L.LAngle _ }-  '>'             { L.RangedToken L.RAngle _ }-  -- Choice-  '|'             { L.RangedToken L.Pipe _ }-  -- Enum-  '..'            { L.RangedToken L.Enum _ }-  -- Polyrhythm-  '%'             { L.RangedToken L.Poly _ }-  -- Lambda-  '\\'            { L.RangedToken L.Lambda _ }-  '->'            { L.RangedToken L.Arrow _ }-  -- Actions-  ';'             { L.RangedToken L.Colon _ }-  '<-'            { L.RangedToken L.StreamA _ }-  ':cps'          { L.RangedToken L.TempoCps _ }-  ':bpm'          { L.RangedToken L.TempoBpm _ }-  ':t'            { L.RangedToken L.TypeA _ }-  ':show'         { L.RangedToken L.ShowA _ }-  ':config'       { L.RangedToken L.ConfigA _ }-  ':resetconfig'  { L.RangedToken L.ResetConfigA _ }-  '='             { L.RangedToken L.Assign _ }-  ':load'         { L.RangedToken (L.LoadA _ ) _}-  ':info'           { L.RangedToken L.InfoA _ }-  -- Type Tokens-  '=>'            { L.RangedToken L.Context _ }-  textT           { L.RangedToken L.TextToken _ }-  numT            { L.RangedToken L.NumberToken _ }-  mapT            { L.RangedToken L.MapToken _ }-  busT            { L.RangedToken L.BusToken _ }-  varT            { L.RangedToken (L.VarToken _) _ }-  classT          { L.RangedToken (L.TypeClass _) _ }--%%----------------------------------------------------------------------------------------- utilities -----------------------------------------------------------------------------------------optional(p)-  :                                             { Nothing }-  | p                                           { Just $1 }--many_rev(p)-  :                                             { [] }-  | many_rev(p) p                               { $2 : $1 }--many(p)-  : many_rev(p)                                 { reverse $1 }--some_rev(p)-  : p                                           { [$1] }-  | some_rev(p) p                               { $2 : $1 }--some(p)-  : some_rev(p)                                 { reverse $1 }--sepBy_rev(p, sep)-  : p                                           { [$1] }-  | sepBy_rev(p, sep) sep p                     { $3 : $1 }--sepBy(p, sep)-  : sepBy_rev(p, sep)                           { reverse $1 }--sepBy_rev2(p, sep)-  : p sep p                                     { [$3, $1] }-  | sepBy_rev2(p, sep) sep p                    { $3 : $1 }--sepBy2(p, sep)-  : sepBy_rev2(p, sep)                          { reverse $1 }--------------------------------------------------------------------------------------- parsing terms ---------------------------------------------------------------------------------------atom :: { Term }-  : identifier                                  { % (mkAtom TVar) $1 }-  | number                                      { % (mkAtom TNum) $1 }-  | string                                      { % (mkAtom TText) $1 }-  | '~'                                         { TRest }--simpleseq :: { [Term] }-  : infix                                %shift { [$1] }-  | infix simpleseq                             { $1: $2 }--seq :: { Term }-  : simpleseq                                   { TSeq $1 }-  | infix '..' infix                            { TEnum Run $1 $3 }-  | infix infix '..' infix                      { TEnumThen Run $1 $2 $4 }-  |                                             { TRest }--sequence :: { Term }-  :  '[' seq ']'                                { $2 }--choice :: { Term }-  : '[' sepBy2(simpleseq, '|') ']'                             { % L.increaseChoice >>= \x -> return $ TChoice x (map TSeq $2) }-  | '[' simpleseq '|' '..' simpleseq ']'                       { TEnum Choice (TSeq $2) (TSeq $5) }-  | '[' simpleseq '|' simpleseq '..' simpleseq ']'             { TEnumThen Choice (TSeq $2) (TSeq $4) (TSeq $6) }--lambda :: { Term }-  : '\\' some(identifier) '->' term      %shift { TLambda (map unTok $2) $4 }--polyrhythm :: { Term }-  : simple '%' simple                    %shift { TPoly $1 $3 }--repeat :: { Term }-  : simple repnum                               { TRepeat $1 (Just $ read $ Text.unpack $ unTok $2) }-  | simple '!'                                  { TRepeat $1 Nothing }--stack :: { Term }-  : '[' sepBy2(simpleseq, ',') ']'                   { TStack (map TSeq $2) }-  | '[' simpleseq ',' '..' simpleseq ']'             { TEnum Cord (TSeq $2) (TSeq $5) }-  | '[' simpleseq ',' simpleseq '..' simpleseq ']'   { TEnumThen Cord (TSeq $2) (TSeq $4) (TSeq $6) }--alt :: { Term }-  : simpleseq                                   { TAlt $1 }-  | infix '..' infix                            { TEnum Alt $1 $3 }-  | infix infix '..' infix                      { TEnumThen Alt $1 $2 $4 }--alternation :: { Term }-  : '<' alt  '>'                                { $2 }--bracket :: { Term }-  : '(' term ')'                                { TBracket $2 }--simple :: { Term }-  : atom                                        { $1 }-  | alternation                                 { $1 }-  | sequence                                    { $1 }-  | choice                                      { $1 }-  | stack                                       { $1 }-  | lambda                                      { $1 }-  | polyrhythm                                  { $1 }-  | repeat                                      { $1 }-  | bracket                                     { $1 }---- special operators are left-associative-specialinfix :: { Term }-  : specialinfix specop simple           %shift { TInfix  $1 (unTok $2) $3 }-  | simple                               %shift { $1 }---- all other operators are assumed to be right-associative, AST rotation will fix it--- this definition is for use inside of sequences-infix :: { Term }-  : specialinfix operator infix          %shift { TInfix  $1 (unTok $2) $3 }-  | specialinfix                         %shift { $1 }---- application is left-associative, binds stronger than operators--- outside of sequences-app :: { Term }-  : app specialinfix                     %shift { TApp $1 $2 }-  | specialinfix                         %shift {$1}--sectionR :: { Term }-  : operator app                         %shift { TSectionR (unTok $1) $2 }--sectionL :: { Term }-  : app operator                         %shift { TSectionL $1 (unTok $2) }---- operators outside of sequences have the weakest binding-term :: { Term }-  : app operator term                    %shift { TInfix  $1 (unTok $2) $3 }-  | app                                  %shift { $1 }-  | sectionR                             %shift { $1 }-  | sectionL                             %shift { $1 }-------------------------------------------------------------------------------------- parsing actions --------------------------------------------------------------------------------------def :: { Def }-  : identifier many(identifier) '=' term        { Let (unTok $1) (map unTok $2) $4 }--action :: { Action }-  : string     '<-' term                        { StreamAction (unTok $1) $3 }-  | number     '<-' term                        { StreamAction (unTok $1) $3 }-  | identifier '<-' term                        { StreamSet (unTok $1) $3 }-  | ':cps' number                               { StreamSetTempo CPS (unTok $2) }-  | ':bpm' number                               { StreamSetTempo BPM (unTok $2) }-  | '!' term                                    { StreamOnce $2 }-  | ':config'                                   { ConfigPath }-  | ':resetconfig'                              { ResetConfig }-  | def                                         { Def $1 }-  | ':t' term                                   { Type $2 }-  | ':show' term                                { Show $2 }-  | ':load'                                     { Load $ unTok $1 }-  | ':info' identifier                          { Info $ unTok $2 }--actionsrecrev :: { [Action] }-  : actionsrecrev ';' action                    { $3:$1 }-  | action                                      { [$1] }--actions :: { [Action] }-  : actionsrecrev ';'                           { reverse $1 }-  | actionsrecrev                               { reverse $1 }-  |                                             { [] }--------------------------------------------------------------------------------------- parsing blocks --------------------------------------------------------------------------------------block :: { Block }-  : some(line)                                  { toBlock $1 }--blocksrec :: { [Block] }-  : blocksrec some(bsep) block                  { $3:$1 }-  | block                                       { [$1] }--blocks :: { [Block] }-  : some(bsep) blocksrec some(bsep)             { $2 }-  | some(bsep) blocksrec                        { $2 }-  | blocksrec some(bsep)                        { $1 }-  | blocksrec                                   { $1 }--------------------------------------------------------------------------------------- parsing types ---------------------------------------------------------------------------------------atomType :: { Type }-  : textT                                       { TypeCon "Text" }-  | numT                                        { TypeCon "Number" }-  | mapT                                        { TypeCon "Map" }-  | busT                                        { TypeCon "Bus" }-  | varT                                        { TypeVar (unTok $1) }--fullType :: { Type }-  : atomType                                    { $1 }-  | fullType '->' fullType               %shift { TypeArr $1 $3 }-  | '(' fullType ')'                            { $2 }--predicate :: { Predicate }-  : classT varT                                 { IsIn (unTok $1) (TypeVar (unTok $2))}--predicates :: { [Predicate] }-  : predicate '=>'                              { [$1] }-  |                                             { [] }--scheme :: { Scheme }-  : predicates fullType                  %shift { generalize $1 $2 }---{--parseError :: (L.RangedToken, [String]) -> L.Alex a-parseError (L.RangedToken t _,poss) = do-  (L.AlexPn _ ln column, _, _, _) <- L.alexGetInput-  L.alexError $ "Parse error at line " <> show ln <> ", column " <> show column-                <> "\n\tunexpected " <> show t-                <> "\n\texpecting " <> (intercalate "," poss)--lexer :: (L.RangedToken -> L.Alex a) -> L.Alex a-lexer = (=<< L.alexMonadScan)--unTok :: L.RangedToken -> Text-unTok (L.RangedToken  (L.Identifier x) _) = x-unTok (L.RangedToken  (L.Number x) _ ) = x-unTok (L.RangedToken  (L.String x) _ )= x-unTok (L.RangedToken  (L.Operator x) _) = x-unTok (L.RangedToken  (L.SpecialOp x) _) = x-unTok (L.RangedToken  (L.LoadA x) _) = x-unTok (L.RangedToken  (L.LineT x) _) = x-unTok (L.RangedToken  (L.VarToken x) _) = x-unTok (L.RangedToken  (L.TypeClass x) _) = x-unTok (L.RangedToken  (L.RepeatNum x) _) = x-unTok _ = error "can't untok"---mkAtom :: (Position -> Text -> Term) -> L.RangedToken -> L.Alex Term-mkAtom constr tok@(L.RangedToken _ range) = do-                          ed <- L.getEditorNum-                          return $ constr (toPosition ed range) (unTok tok)--toPosition :: Int -> L.Range -> Position-toPosition ed (L.Range (L.AlexPn _ line start) (L.AlexPn _ _ end)) = Pos line start end ed--toBlock :: [L.RangedToken] -> Block-toBlock [] = error "Can't happen"-toBlock xs = Block start end content-           where ls = sortOn (\(x,_) -> x) $ map (\r -> (getLn r,unTok r)) xs-                 (start, _) = head ls-                 (end, _) = last ls-                 content = Text.concat $ map snd ls-                 getLn (L.RangedToken _ (L.Range (L.AlexPn _ l _) _)) = l---parseActionsWithPos :: Int -> Int -> Text -> Either String [Action]-parseActionsWithPos ln ed input = L.runAlex input (L.setEditorNum ed >> L.setInitialLineNum ln >> pActions)--parseActions :: Text -> Either String [Action]-parseActions input = L.runAlex input pActions--parseBlocks :: Int -> Text -> Either String [Block]-parseBlocks line input = L.runAlex input (L.lineLexer >> L.setInitialLineNum line >> pBlocks)--parseScheme :: Text -> Either String Scheme-parseScheme input = L.runAlex input (L.typeLexer >> pScheme)--}
− src/Zwirn/Language/Pretty.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -Wno-orphans #-}--module Zwirn.Language.Pretty-  ( ppterm,-    ppscheme,-    ppTermHasType,-  )-where--{--    Pretty.hs - pretty printer for the AST and the types-    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 Data.List (intercalate)-import Data.Text (unpack)-import Text.PrettyPrint-import Zwirn.Language.Syntax-import Zwirn.Language.TypeCheck.Constraint-import Zwirn.Language.TypeCheck.Types-import Prelude hiding ((<>))--parensIf :: Bool -> Doc -> Doc-parensIf True = parens-parensIf False = id--class Pretty p where-  ppr :: Int -> p -> Doc--instance Pretty Name where-  ppr _ x = text $ unpack x--instance Pretty Type where-  ppr p (TypeArr a b) = parensIf (isArrow a) (ppr p a) <+> text "->" <+> ppr p b-    where-      isArrow TypeArr {} = True-      isArrow _ = False-  ppr p (TypeVar a) = ppr p a-  ppr _ (TypeCon a) = text $ unpack a--instance Pretty Predicate where-  ppr p (IsIn c t) = text (unpack c) <+> ppr p t--instance Pretty [Predicate] where-  ppr p ps = parensIf (length ps > 1) (hcat (punctuate comma (map (ppr p) ps)))--instance Pretty (Qualified Type) where-  ppr p (Qual [] t) = ppr p t-  ppr p (Qual ps t) = ppr p ps <+> text "=>" <+> ppr p t--instance Pretty Scheme where-  ppr p (Forall _ t) = ppr p t--instance Pretty Term where-  ppr _ (TVar _ x) = text $ unpack x-  ppr _ TRest = text "~"-  ppr _ (TText _ x) = text $ unpack x-  ppr _ (TNum _ x) = double $ read $ unpack x-  ppr p (TRepeat t (Just i)) = ppr p t <> text "!" <> int i-  ppr p (TRepeat t Nothing) = ppr p t <> text "!"-  ppr p (TSeq [t]) = ppr p t-  ppr p (TSeq ts) = brackets (hcat (punctuate space (map (ppr p) ts)))-  ppr p (TAlt ts) = text "<" <> hcat (punctuate space (map (ppr p) ts)) <> text ">"-  ppr p (TChoice _ ts) = brackets (hcat $ punctuate (text "|") (map (ppr p) ts))-  ppr p (TStack ts) = brackets (hcat $ punctuate comma (map (ppr p) ts))-  ppr p (TPoly t1 t2) = ppr p t1 <> text "%" <> ppr p t2-  ppr p (TApp t1 t2) = parensIf (p > 0) (ppr (p + 1) t1 <+> ppr p t2)-  ppr p (TInfix t1 n t2) = ppr p t1 <+> text (unpack n) <+> ppr p t2-  ppr p (TBracket t) = parens (ppr p t)-  ppr p (TLambda vs t) = text "\\" <> hcat (punctuate space $ map (text . unpack) vs) <+> text "->" <+> ppr p t-  ppr p (TSectionL t n) = ppr p t <+> text (unpack n)-  ppr p (TSectionR n t) = text (unpack n) <+> ppr p t-  ppr p (TEnum Run x y) = brackets (ppr p x <+> text ".." <+> ppr p y)-  ppr p (TEnumThen Alt x y z) = text "<" <> (ppr p x <+> ppr p y <+> text ".." <+> ppr p z) <> text ">"-  ppr p (TEnum Alt x y) = text "<" <> (ppr p x <+> text ".." <+> ppr p y) <> text ">"-  ppr p (TEnumThen Run x y z) = brackets (ppr p x <+> ppr p y <+> text ".." <+> ppr p z)-  ppr p (TEnum Cord x y) = brackets (ppr p x <+> text ", .." <+> ppr p y)-  ppr p (TEnumThen Cord x y z) = brackets (ppr p x <+> text "," <+> ppr p y <+> text ".." <+> ppr p z)-  ppr p (TEnum Choice x y) = brackets (ppr p x <+> text "| .. " <+> ppr p y)-  ppr p (TEnumThen Choice x y z) = brackets (ppr p x <+> text "|" <+> ppr p y <+> text ".." <+> ppr p z)--instance Pretty (Term, Scheme) where-  ppr p (t, s) = ppr p t <+> text "::" <+> ppr p s--pptype :: Type -> String-pptype = render . ppr 0--ppscheme :: Scheme -> String-ppscheme = render . ppr 0--ppterm :: Term -> String-ppterm = render . ppr 0--ppTermHasType :: (Term, Scheme) -> String-ppTermHasType = render . ppr 0--instance Show TypeError where-  show (UnificationFail a b) =-    concat ["Cannot unify types: \n\t", pptype a, " ~ ", pptype b]-  show (UnificationMismatch as bs) =-    concat ["Cannot unify types: \n\t", intercalate "," $ map pptype as, " ~ ", intercalate "," $ map pptype bs]-  show (InfiniteType a b) =-    concat ["Cannot construct the infinite type: ", unpack a, " = ", pptype b]-  show (Ambigious cs) =-    concat ["Cannot not match expected type: '" ++ pptype a ++ "' with actual type: '" ++ pptype b ++ "'\n" | (a, b) <- cs]-  show (UnboundVariable a) = "Not in scope: " ++ unpack a-  show (NoInstance (IsIn c x)) = "No instance for " ++ unpack c ++ " " ++ pptype x
− src/Zwirn/Language/Rotate.hs 
@@ -1,126 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Zwirn.Language.Rotate-  ( runRotate,-    runRotateUnsafe,-    RotationError,-  )-where--{--    Rotate.hs - syntax tree rotation, code adapted from-    https://gist.github.com/heitor-lassarote/b20d6da0a9042d31e439befb8c236a4e-    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 Control.Monad.Except-import Control.Monad.Identity-import Zwirn.Language.Simple-import Zwirn.Language.Syntax--ops :: [Declaration]-ops =-  [ ("*", Fixity LeftA 9),-    ("/", Fixity LeftA 9),-    ("$", Fixity RightA 0),-    ("$|", Fixity RightA 0),-    ("|$", Fixity RightA 0),-    (".", Fixity RightA 9),-    ("#", Fixity RightA 3),-    ("++", Fixity RightA 4),-    ("+", Fixity LeftA 6),-    ("|+", Fixity LeftA 6),-    ("+|", Fixity LeftA 6),-    ("|*", Fixity LeftA 7),-    ("*|", Fixity LeftA 7),-    ("//", Fixity LeftA 7),-    ("|/", Fixity LeftA 7),-    ("/|", Fixity LeftA 7)-  ]--defaultFixity :: Fixity-defaultFixity = Fixity LeftA 8--type RotationError = String--type Rotate a = ExceptT RotationError Identity a---- | Describes which action the rotation algorithm should use.-data Rotation-  = -- | Fail due to the mixing of incompatible operators.-    Fail-  | -- | Keep the tree as it is.-    Keep-  | -- | Balance the tree to the left.-    Rotate--runRotate :: SimpleTerm -> Either RotationError SimpleTerm-runRotate t = runIdentity $ runExceptT $ rotate t--runRotateUnsafe :: SimpleTerm -> SimpleTerm-runRotateUnsafe t = case runRotate t of-  Left err -> error $ show err-  Right r -> r---- | The Happy parser is written in a way so that it will always create a right-balanced AST.--- We compare the operators and indicate how to rotate the tree.-shouldRotate :: Fixity -> Fixity -> Rotation-shouldRotate (Fixity a p) (Fixity a' p') = case compare p p' of-  LT -> Keep-  EQ -> case (a, a') of-    (LeftA, LeftA) -> Rotate-    (RightA, RightA) -> Keep-    (_, _) -> Fail-  GT -> Rotate---- | Rebalances the tree to respect the associativity and precedence of the--- parsed operators.---- Not very efficient, but enough for demonstration purposes.-findOp :: OperatorSymbol -> Rotate Fixity-findOp o = case lookup o ops of-  Just d -> return d-  Nothing -> return defaultFixity--rotate :: SimpleTerm -> Rotate SimpleTerm-rotate (SInfix l op r) = do-  -- Rotating the left side is unneeded since this grammar is very simple.-  -- This is because trees are always right-balanced and the left side is-  -- always an atom.-  lRotated <- rotate l-  rRotated <- rotate r-  case rRotated of-    SInfix l' op' r' -> do-      opDec <- findOp op-      opDec' <- findOp op'-      case shouldRotate opDec opDec' of-        Fail -> throwError "can't handle precedence of operators"-        Keep -> return $ SInfix lRotated op rRotated-        Rotate -> return $ SInfix (SInfix lRotated op l') op' r'-    _ -> return $ SInfix lRotated op rRotated-rotate (SApp l r) = do-  lRotated <- rotate l-  rRotated <- rotate r-  return $ SApp lRotated rRotated-rotate e@(SVar _ _) = return e-rotate e@(SText _ _) = return e-rotate e@(SNum _ _) = return e-rotate SRest = return SRest-rotate (SSeq ts) = fmap SSeq (mapM rotate ts)-rotate (SStack ts) = fmap SStack (mapM rotate ts)-rotate (SChoice n ts) = fmap (SChoice n) (mapM rotate ts)-rotate (SLambda vs t) = SLambda vs <$> rotate t-rotate (SBracket t) = fmap SBracket (rotate t)
− src/Zwirn/Language/Simple.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Zwirn.Language.Simple-  ( simplify,-    simplifyDef,-    SimpleTerm (..),-    SimpleDef (..),-    Position (..),-  )-where--{--    Simple.hs - desugaring of the zwirn AST-    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 Data.Text as Text (Text, filter, pack)-import Zwirn.Language.Syntax---- simple representation of patterns-data SimpleTerm-  = SVar (Maybe Position) Var-  | SText Position Text-  | SNum (Maybe Position) Text-  | SRest-  | SSeq [SimpleTerm]-  | SStack [SimpleTerm]-  | SChoice Int [SimpleTerm]-  | SLambda Var SimpleTerm-  | SApp SimpleTerm SimpleTerm-  | SInfix SimpleTerm OperatorSymbol SimpleTerm-  | SBracket SimpleTerm-  deriving (Eq, Show)--data SimpleDef-  = LetS Var SimpleTerm-  deriving (Eq, Show)--simplify :: Term -> SimpleTerm-simplify (TVar p x) = SVar (Just p) x-simplify (TText p x) = SText p $ stripText x-  where-    stripText = Text.filter (/= '\"')-simplify (TNum p x) = SNum (Just p) x-simplify TRest = SRest-simplify x@(TRepeat _ _) = SSeq $ map simplify $ resolveRepeat x-simplify (TSeq ts) = SSeq (map simplify $ concatMap resolveRepeat ts)-simplify (TStack ts) = SStack (map simplify ts)-simplify (TChoice i ts) = SChoice i (map simplify ts)-simplify (TAlt ts) = SBracket $ SInfix (SSeq ss) "/" (SNum Nothing (pack $ show $ length ss))-  where-    ss = map simplify $ concatMap resolveRepeat ts-simplify (TPoly (TSeq ts) n) = SBracket $ SInfix (SInfix (SSeq ss) "/" (SNum Nothing (pack $ show $ length ss))) "*" (simplify n)-  where-    ss = map simplify $ concatMap resolveRepeat ts-simplify (TPoly x n) = SInfix (simplify x) "*" (simplify n)-simplify (TLambda [] t) = simplify t-simplify (TLambda (x : xs) t) = SLambda x (simplify $ TLambda xs t)-simplify (TApp x y) = SApp (simplify x) (simplify y)-simplify (TInfix x op y) = SInfix (simplify x) op (simplify y)-simplify (TSectionR op y) = SLambda "_x" (SInfix (SVar Nothing "_x") op (simplify y))-simplify (TSectionL x op) = SLambda "_x" (SInfix (simplify x) op (SVar Nothing "_x"))-simplify (TBracket x) = SBracket (simplify x)-simplify (TEnum Run x y) = SApp (SApp (SVar Nothing "runFromTo") (simplify x)) (simplify y)-simplify (TEnumThen Run x y z) = SApp (SApp (SApp (SVar Nothing "runFromThenTo") (simplify x)) (simplify y)) (simplify z)-simplify (TEnum Alt x y) = SApp (SApp (SVar Nothing "slowrunFromTo") (simplify x)) (simplify y)-simplify (TEnumThen Alt x y z) = SApp (SApp (SApp (SVar Nothing "slowrunFromThenTo") (simplify x)) (simplify y)) (simplify z)-simplify (TEnum Cord x y) = SApp (SApp (SVar Nothing "cordFromTo") (simplify x)) (simplify y)-simplify (TEnumThen Cord x y z) = SApp (SApp (SApp (SVar Nothing "cordFromThenTo") (simplify x)) (simplify y)) (simplify z)-simplify (TEnum Choice x y) = SApp (SApp (SVar Nothing "chooseFromTo") (simplify x)) (simplify y)-simplify (TEnumThen Choice x y z) = SApp (SApp (SApp (SVar Nothing "chooseFromThenTo") (simplify x)) (simplify y)) (simplify z)--simplifyDef :: Def -> SimpleDef-simplifyDef (Let x vs t) = LetS x (simplify $ TLambda vs t)--resolveRepeat :: Term -> [Term]-resolveRepeat t = case getTotalRepeat t of-  TRepeat x (Just i) -> replicate i x-  TRepeat x Nothing -> [x, x]-  x -> [x]---- TODO : not completely right when Nothing followed by Just...-getRepeat :: (Term, Int) -> Term-getRepeat (TRepeat x (Just j), k) = getRepeat (x, j * k)-getRepeat (TRepeat x Nothing, k) = getRepeat (x, k + 1)-getRepeat (x, j) = TRepeat x (Just j)--getTotalRepeat :: Term -> Term-getTotalRepeat (TRepeat t (Just i)) = getRepeat (t, i)-getTotalRepeat (TRepeat t Nothing) = getRepeat (t, 2)-getTotalRepeat t = t
− src/Zwirn/Language/Syntax.hs 
@@ -1,95 +0,0 @@-module Zwirn.Language.Syntax where--{--    Syntax.hs - definition of the zwirn language,-    inspired by tidals mini-notation-    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 Data.Text (Text)--type Var = Text--type OperatorSymbol = Text--data Position = Pos-  { pLine :: Int,-    pStart :: Int,-    pEnd :: Int,-    pEditor :: Int-  }-  deriving (Eq, Show)--data EnumKind = Cord | Choice | Run | Alt deriving (Eq, Show)---- sugary representation of patterns-data Term-  = TVar Position Text-  | TText Position Text-  | TNum Position Text-  | TRest-  | TRepeat Term (Maybe Int)-  | TSeq [Term]-  | TStack [Term]-  | TAlt [Term]-  | TChoice Int [Term]-  | TPoly Term Term-  | TLambda [Text] Term-  | TApp Term Term-  | TInfix Term Text Term-  | TSectionR Text Term-  | TSectionL Term Text-  | TBracket Term-  | TEnum EnumKind Term Term-  | TEnumThen EnumKind Term Term Term-  deriving (Eq, Show)--data Def-  = Let Text [Text] Term-  deriving (Eq, Show)--data Tempo-  = CPS-  | BPM-  deriving (Eq, Show)--data Action-  = StreamAction Text Term-  | StreamSet Text Term-  | StreamOnce Term-  | StreamSetTempo Tempo Text-  | ConfigPath-  | ResetConfig-  | Def Def-  | Type Term-  | Show Term-  | Load Text-  | Info Text-  deriving (Eq, Show)--data Associativity-  = NonA-  | LeftA-  | RightA-  deriving (Eq, Show)--type Precedence = Int--data Fixity-  = Fixity Associativity Precedence-  deriving (Eq, Show)--type Declaration = (OperatorSymbol, Fixity)
− src/Zwirn/Language/TypeCheck/Constraint.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Zwirn.Language.TypeCheck.Constraint-  ( Substitutable (..),-    Subst (..),-    TypeError (..),-    Constraint,-    runSolve,-  )-where--{--    Constraint.hs - unification constraint solver adapted from-    https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints-    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 Control.Monad.Except-import Control.Monad.Identity-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Text (Text)-import Zwirn.Language.Environment-import Zwirn.Language.TypeCheck.Types--data TypeError-  = UnificationFail Type Type-  | InfiniteType TypeVar Type-  | UnboundVariable Text-  | Ambigious [Constraint]-  | UnificationMismatch [Type] [Type]-  | NoInstance Predicate-  deriving (Eq)--type Constraint = (Type, Type)--newtype Subst = Subst (Map.Map TypeVar Type)-  deriving (Eq, Ord, Show, Semigroup, Monoid)--type Unifier = (Subst, [Constraint])---- | Constraint solver monad-type Solve a = ExceptT TypeError Identity a--class Substitutable a where-  apply :: Subst -> a -> a-  ftv :: a -> Set.Set TypeVar--instance Substitutable Type where-  apply _ (TypeCon a) = TypeCon a-  apply (Subst s) t@(TypeVar a) = Map.findWithDefault t a s-  apply s (t1 `TypeArr` t2) = apply s t1 `TypeArr` apply s t2--  ftv TypeCon {} = Set.empty-  ftv (TypeVar a) = Set.singleton a-  ftv (t1 `TypeArr` t2) = ftv t1 `Set.union` ftv t2--instance Substitutable Scheme where-  apply (Subst s) (Forall as t) = Forall as $ apply s' t-    where-      s' = Subst $ foldr Map.delete s as-  ftv (Forall as t) = ftv t `Set.difference` Set.fromList as--instance Substitutable Constraint where-  apply s (t1, t2) = (apply s t1, apply s t2)-  ftv (t1, t2) = ftv t1 `Set.union` ftv t2--instance Substitutable AnnotatedExpression where-  apply s (Annotated x sc d) = Annotated x (apply s sc) d-  ftv (Annotated _ s _) = ftv s--instance (Substitutable a) => Substitutable [a] where-  apply = map . apply-  ftv = foldr (Set.union . ftv) Set.empty--instance Substitutable InterpreterEnv where-  apply s (IEnv ty cl) = IEnv (Map.map (apply s) ty) (apply s cl)-  ftv (IEnv ty cl) = ftv (Map.elems ty) `Set.union` ftv cl--instance Substitutable Predicate where-  apply s (IsIn x t) = IsIn x (apply s t)-  ftv (IsIn _ t) = ftv t--instance (Substitutable t) => Substitutable (Qualified t) where-  apply s (Qual ps t) = Qual (apply s ps) (apply s t)-  ftv (Qual ps t) = ftv ps `Set.union` ftv t------------------------------------------------------------------------------------ Constraint Solver------------------------------------------------------------------------------------ | The empty substitution-emptySubst :: Subst-emptySubst = mempty---- | Compose substitutions-compose :: Subst -> Subst -> Subst-(Subst s1) `compose` (Subst s2) = Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1---- | Run the constraint solver-runSolve :: [Constraint] -> Either TypeError Subst-runSolve cs = runIdentity $ runExceptT $ solver st-  where-    st = (emptySubst, cs)--unifyMany :: [Type] -> [Type] -> Solve Subst-unifyMany [] [] = return emptySubst-unifyMany (t1 : ts1) (t2 : ts2) =-  do-    su1 <- unifies t1 t2-    su2 <- unifyMany (apply su1 ts1) (apply su1 ts2)-    return (su2 `compose` su1)-unifyMany t1 t2 = throwError $ UnificationMismatch t1 t2--unifies :: Type -> Type -> Solve Subst-unifies t1 t2 | t1 == t2 = return emptySubst-unifies (TypeVar v) t = v `bind` t-unifies t (TypeVar v) = v `bind` t-unifies (TypeArr t1 t2) (TypeArr t3 t4) = unifyMany [t1, t2] [t3, t4]-unifies t1 t2 = throwError $ UnificationFail t1 t2---- Unification solver-solver :: Unifier -> Solve Subst-solver (su, cs) =-  case cs of-    [] -> return su-    ((t1, t2) : cs0) -> do-      su1 <- unifies t1 t2-      solver (su1 `compose` su, apply su1 cs0)--bind :: TypeVar -> Type -> Solve Subst-bind a t-  | t == TypeVar a = return emptySubst-  | occursCheck a t = throwError $ InfiniteType a t-  | otherwise = return (Subst $ Map.singleton a t)--occursCheck :: (Substitutable a) => TypeVar -> a -> Bool-occursCheck a t = a `Set.member` ftv t
− src/Zwirn/Language/TypeCheck/Infer.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Zwirn.Language.TypeCheck.Infer-  ( inferTerm,-    generalize,-  )-where--{--    Infer.hs - type inference algorithm adapted from-    https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints-    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 Control.Monad (replicateM)-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.State-import Data.List (nub)-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Text (Text, pack)--- import Zwirn.Language.TypeCheck.Env as Env--import Zwirn.Language.Environment-import Zwirn.Language.Simple-import Zwirn.Language.TypeCheck.Constraint-import Zwirn.Language.TypeCheck.Types---- | Inference monad-type Infer a =-  ( ReaderT-      InterpreterEnv -- Typing environment-      ( StateT -- Inference state-          InferState-          ( Except -- Inference errors-              TypeError-          )-      )-      a -- Result-  )---- | Inference state-newtype InferState = InferState {count :: Int}---- | Initial inference state-initInfer :: InferState-initInfer = InferState {count = 0}------------------------------------------------------------------------------------ Inference------------------------------------------------------------------------------------ | Run the inference monad-runInfer :: InterpreterEnv -> Infer a -> Either TypeError a-runInfer env m = runExcept $ evalStateT (runReaderT m env) initInfer---- | Solve for the toplevel type of an expression in a given environment-inferTerm :: InterpreterEnv -> SimpleTerm -> Either TypeError Scheme-inferTerm env ex = case runInfer env (infer ex) of-  Left err -> Left err-  Right (ty, ps, cs) -> case runSolve cs of-    Left err -> Left err-    Right subst -> case runInfer env (filterAndCheck (apply subst ps) (apply subst ty)) of-      Left err -> Left err-      Right xs -> Right $ closeOver xs $ apply subst ty---- | Return the internal constraints used in solving for the type of an expression--- constraintsTerm :: Env -> SimpleTerm -> Either TypeError ([Constraint], Subst, Type, Scheme)--- constraintsTerm env ex = case runInfer env (infer ex) of---   Left err -> Left err---   Right (ty, cs) -> case runSolve cs of---     Left err -> Left err---     Right subst -> Right (cs, subst, ty, sc)---       where---         sc = closeOver $ apply subst ty---- | Canonicalize and return the polymorphic toplevel type.-closeOver :: [Predicate] -> Type -> Scheme-closeOver ps t = normalize $ generalize ps t---- | modified environment where x :: sc-inEnv :: (Name, Scheme) -> Infer a -> Infer a-inEnv (x, sc) m = do-  let scope = insertType x sc-  local scope m---- | Lookup type in the environment-lookupEnv :: Name -> Infer (Type, [Predicate])-lookupEnv x = do-  env <- ask-  case lookupType x env of-    Nothing -> throwError $ UnboundVariable x-    Just s -> instantiate s--letters :: [Text]-letters = map pack $ [1 ..] >>= flip replicateM ['a' .. 'z']--fresh :: Infer Type-fresh = do-  s <- get-  put s {count = count s + 1}-  return $ TypeVar (letters !! count s)--instantiate :: Scheme -> Infer (Type, [Predicate])-instantiate (Forall as (Qual ps t)) = do-  as' <- mapM (const fresh) as-  let s = Subst $ Map.fromList $ zip as as'-  return $ (apply s t, apply s ps)--generalize :: [Predicate] -> Type -> Scheme-generalize ps t = Forall as (Qual ps t)-  where-    as = Set.toList $ ftv t--filterAndCheck :: [Predicate] -> Type -> Infer [Predicate]-filterAndCheck [] _ = return []-filterAndCheck (p@(IsIn _ (TypeVar _)) : ps) t =-  if or $ Set.map (\x -> elem x $ ftv p) (ftv t)-    then (p :) <$> filterAndCheck ps t-    else filterAndCheck ps t-filterAndCheck (p : ps) t = checkInstance p >> filterAndCheck ps t--checkInstance :: Predicate -> Infer ()-checkInstance p = do-  (IEnv _ is) <- ask-  (if p `elem` is then return () else throwError $ NoInstance p)--infer :: SimpleTerm -> Infer (Type, [Predicate], [Constraint])-infer expr = case expr of-  SVar _ x -> do-    (t, ps) <- lookupEnv x-    return (t, ps, [])-  SText _ _ -> return (textT, [], [])-  SNum _ _ -> return (numberT, [], [])-  SBracket s -> infer s-  SRest -> do-    tv <- fresh-    return (tv, [], [])-  SLambda x e -> do-    tv <- fresh-    (t, ps, c) <- inEnv (x, Forall [] (Qual [] tv)) (infer e)-    return (tv `TypeArr` t, ps, c)-  SApp e1 e2 -> do-    (t1, ps1, c1) <- infer e1-    (t2, ps2, c2) <- infer e2-    tv <- fresh-    return (tv, ps1 ++ ps2, c1 ++ c2 ++ [(t1, t2 `TypeArr` tv)])-  SInfix e1 op e2 -> do-    (t1, ps1, c1) <- infer e1-    (t2, ps2, c2) <- infer e2-    tv <- fresh-    let u1 = t1 `TypeArr` (t2 `TypeArr` tv)-    (u2, p3) <- lookupEnv op-    return (tv, ps1 ++ ps2 ++ p3, c1 ++ c2 ++ [(u1, u2)])-  SSeq (x : xs) -> do-    (t, ps, cs) <- infer x-    infs <- mapM infer xs-    return (t, ps, cs ++ concatMap (\(_, _, y) -> y) infs ++ [(t, t') | t' <- map (\(y, _, _) -> y) infs])-  SStack (x : xs) -> do-    (t, ps, cs) <- infer x-    infs <- mapM infer xs-    return (t, ps, cs ++ concatMap (\(_, _, y) -> y) infs ++ [(t, t') | t' <- map (\(y, _, _) -> y) infs])-  SChoice _ (x : xs) -> do-    (t, ps, cs) <- infer x-    infs <- mapM infer xs-    return (t, ps, cs ++ concatMap (\(_, _, y) -> y) infs ++ [(t, t') | t' <- map (\(y, _, _) -> y) infs])-  _ -> error "Can't happen"--normalize :: Scheme -> Scheme-normalize (Forall _ (Qual ps body)) = Forall (map snd ord) (Qual (map normpred ps) $ normtype body)-  where-    ord = zip (nub $ fv body) letters--    fv (TypeVar a) = [a]-    fv (TypeArr a b) = fv a ++ fv b-    fv (TypeCon _) = []--    normtype (TypeArr a b) = TypeArr (normtype a) (normtype b)-    normtype (TypeCon a) = TypeCon a-    normtype (TypeVar a) =-      case Prelude.lookup a ord of-        Just x -> TypeVar x-        Nothing -> error "type variable not in signature"--    normpred (IsIn n t) = IsIn n (normtype t)
− src/Zwirn/Language/TypeCheck/Types.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Zwirn.Language.TypeCheck.Types where--{--    Types.hs - defintion of types adapted from-    https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints-    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 Data.Text (Text)--type Name = Text--type TypeVar = Text--data Type-  = TypeVar TypeVar-  | TypeCon Text-  | TypeArr Type Type-  deriving (Show, Eq, Ord)--data Predicate-  = IsIn Name Type-  deriving (Show, Eq, Ord)--data Qualified t-  = Qual [Predicate] t-  deriving (Show, Eq, Ord)--data Scheme-  = Forall [TypeVar] (Qualified Type)-  deriving (Show, Eq)--type Instance = Predicate--numberT :: Type-numberT = TypeCon "Number"--textT :: Type-textT = TypeCon "Text"--mapT :: Type-mapT = TypeCon "Map"--busT :: Type-busT = TypeCon "Bus"--varA :: Type-varA = TypeVar "a"--varB :: Type-varB = TypeVar "b"--varC :: Type-varC = TypeVar "c"--isBasicType :: Scheme -> Bool-isBasicType (Forall [] (Qual [] (TypeCon "Bus"))) = False-isBasicType (Forall [] (Qual [] (TypeCon _))) = True-isBasicType (Forall _ (Qual [] (TypeVar _))) = True-isBasicType _ = False--isBus :: Scheme -> Bool-isBus (Forall [] (Qual [] (TypeCon "Bus"))) = True-isBus (Forall _ (Qual [] (TypeVar _))) = True-isBus _ = False--infixr 1 -->--(-->) :: Type -> Type -> Type-(-->) = TypeArr--unqual :: Type -> Qualified Type-unqual = Qual []
− src/Zwirn/Stream.hs 
@@ -1,229 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# OPTIONS_GHC -Wno-type-defaults #-}--module Zwirn.Stream where--{--    Stream.hs - query and send messages, code adapted from-    https://github.com/tidalcycles/Tidal/tree/dev/src/Sound/Tidal/Stream-    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 Control.Concurrent (forkIO)-import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar, swapMVar)-import Control.Monad (when)-import Data.Bifunctor (second)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, isJust)-import Data.Text (Text, pack)-import qualified Data.Text as T-import GHC.Generics (Generic)-import qualified Network.Socket as N-import qualified Sound.Osc as O-import Sound.Osc.Time.Timeout (recvPacketTimeout)-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.Cord (stack)-import Zwirn.Core.Query-import qualified Zwirn.Core.Time as Z-import Zwirn.Language.Evaluate--type PlayMap = Map.Map Text (Zwirn Expression)--type BusMap = Map.Map Int (Zwirn Expression)--data StreamConfig = StreamConfig-  { streamConfigPort :: Int,-    streamConfigBusPort :: Int,-    streamConfigAddress :: String-  }-  deriving (Generic)--data Stream = Stream-  { sPlayMap :: MVar PlayMap,-    sBusMap :: MVar BusMap,-    sState :: MVar ExpressionMap,-    sBusses :: MVar [Int],-    sAddress :: RemoteAddress,-    sBusAddress :: RemoteAddress,-    sLocal :: O.Udp,-    sClockRef :: ClockRef,-    sClockConfig :: ClockConfig-  }--type RemoteAddress = N.SockAddr--streamReplace :: Stream -> Text -> Zwirn Expression -> IO ()-streamReplace str key p = modifyMVar_ (sPlayMap str) (return . Map.insert key p)--streamReplaceBus :: Stream -> Int -> Zwirn Expression -> IO ()-streamReplaceBus str key p = modifyMVar_ (sBusMap str) (return . Map.insert key p)--streamSet :: Stream -> T.Text -> Expression -> IO ()-streamSet str x ex = modifyMVar_ (sState str) (return . Map.insert x ex)--streamSetCPS :: Stream -> Time -> IO ()-streamSetCPS s = Clock.setCPS (sClockConfig s) (sClockRef s)--streamSetBPM :: Stream -> Time -> IO ()-streamSetBPM s = Clock.setBPM (sClockRef s)--streamFirst :: Stream -> Zwirn Expression -> IO ()-streamFirst str z = do-  dummy <- newMVar $ Map.singleton (pack "_streamOnceDummy_") z-  Clock.clockOnce (tickAction dummy (sBusMap str) (sState str) (sBusses str) (sAddress str) (sBusAddress str) (sLocal str)) (sClockConfig str) (sClockRef str)--startStream :: StreamConfig -> MVar PlayMap -> MVar ExpressionMap -> ClockConfig -> IO Stream-startStream config zMV stMV conf = do-  let target_address = streamConfigAddress config-      target_port = streamConfigPort config-      target_bus_port = streamConfigBusPort config-  remote <- resolve target_address target_port-  remoteBus <- resolve target_address target_bus_port-  local <- O.udp_server 2323--  busMapMV <- newMVar Map.empty-  bussesMV <- newMVar []--  _ <- forkIO $ handshake (N.addrAddress remote) local bussesMV--  cref <- clocked conf (tickAction zMV busMapMV stMV bussesMV (N.addrAddress remote) (N.addrAddress remoteBus) local)-  return $ Stream zMV busMapMV stMV bussesMV (N.addrAddress remote) (N.addrAddress remoteBus) local cref conf--tickAction :: MVar PlayMap -> MVar BusMap -> MVar ExpressionMap -> MVar [Int] -> RemoteAddress -> RemoteAddress -> O.Udp -> (Time, Time) -> Double -> ClockConfig -> ClockRef -> (SessionState, SessionState) -> IO ()-tickAction zMV busMapMV stMV bussesMV remote remoteBus local (star, end) nudge cconf cref (ss, _) = do-  cps <- Clock.getCPS cconf cref-  vs <- processPlayMap (star, end) cps zMV stMV-  bs <- processBusMap (star, end) busMapMV stMV bussesMV-  mapM_ (processAndSend remote local nudge cconf cref ss) vs-  mapM_ (processAndSend remoteBus local nudge cconf cref ss) bs--processPlayMap :: (Time, Time) -> Time -> MVar PlayMap -> MVar ExpressionMap -> IO [(Z.Time, O.Message)]-processPlayMap (star, end) cps zMV stMV = do-  pm <- readMVar zMV-  let p = playMapToCord pm-  st <- readMVar stMV-  let qs = findAllValuesWithTimeState (Z.Time (align star) 1, Z.Time (align end) 1) st p-      vs = map (\(t, v, _) -> (t, v)) qs-      sts = map (\(_, _, x) -> x) qs--  -- TODO: what about race conditions?-  updateState stMV sts--  return $ (\(t, ex) -> (t, expressionToMessage (fromIntegral $ floor t) (realToFrac cps) ex)) <$> vs--processBusMap :: (Time, Time) -> MVar BusMap -> MVar ExpressionMap -> MVar [Int] -> IO [(Z.Time, O.Message)]-processBusMap (star, end) busMV stMV bussesMV = do-  bm <- readMVar busMV-  let bs = Map.toList bm-  busses <- readMVar bussesMV-  st <- readMVar stMV-  return $ concatMap (\(i, p) -> second (busExpressionToMessage $ toBus busses i) <$> findAllValuesWithTime (Z.Time (align star) 1, Z.Time (align end) 1) st p) bs--toBus :: [Int] -> Int -> Int-toBus [] i = i-toBus xs i = xs !! (i `mod` length xs)--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--playMapToCord :: PlayMap -> Zwirn Expression-playMapToCord = stack . Map.elems--align :: Time -> Time-align t = fromIntegral (floor $ t / 0.001) * 0.001--expressionToOSC :: Expression -> [O.Datum]-expressionToOSC (ENum n) = [O.float n]-expressionToOSC (EText n) = [O.string $ T.unpack n]-expressionToOSC (EMap m) = concatMap (\(k, v) -> O.string (T.unpack k) : expressionToOSC v) $ Map.toList m-expressionToOSC _ = []--additionalData :: Double -> Double -> [O.Datum]-additionalData cyc cps = [O.string "cps", O.float cps, O.string "cycle", O.float cyc]--expressionToMessage :: Double -> Double -> Expression -> O.Message-expressionToMessage cyc cps ex = O.message "/dirt/play" (additionalData cyc cps ++ expressionToOSC ex)--busExpressionToMessage :: Int -> Expression -> O.Message-busExpressionToMessage bus ex = O.message "/c_set" (O.int32 bus : expressionToOSC ex)--sendMessage :: RemoteAddress -> O.Udp -> Double -> Double -> (Double, O.Message) -> IO ()-sendMessage remote local latency extraLatency (time, m) = sendBndl remote local $ O.Bundle timeWithLatency [m]-  where-    timeWithLatency = time - latency + extraLatency--sendBndl :: RemoteAddress -> O.Udp -> O.Bundle -> IO ()-sendBndl remote local bndl = O.sendTo local (O.Packet_Bundle bndl) remote--defaultLatency :: Double-defaultLatency = 0.2--processAndSend :: RemoteAddress -> O.Udp -> Double -> ClockConfig -> ClockRef -> SessionState -> (Z.Time, O.Message) -> IO ()-processAndSend remote local nudge cconf cref ss (t, msg) = do-  let onBeat = Clock.cyclesToBeat cconf (realToFrac ((\(Z.Time r _) -> fromRational r) t))--  on <- Clock.timeAtBeat cconf ss onBeat-  onOSC <- Clock.linkToOscTime cref on--  sendMessage remote local defaultLatency nudge (onOSC, msg)--updateState :: MVar ExpressionMap -> [ExpressionMap] -> IO ()-updateState _ [] = return ()-updateState stmv (st : _) = modifyMVar_ stmv (const $ return st)--handshake :: RemoteAddress -> O.Udp -> MVar [Int] -> IO ()-handshake addr udp bussesMV = sendHandshake >> listen 0-  where-    sendHandshake :: IO ()-    sendHandshake = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" []) addr-    listen :: Int -> IO ()-    listen waits = do-      ms <- recvMessagesTimeout 2 udp-      if null ms-        then do-          checkHandshake waits -- there was a timeout, check handshake-          listen (waits + 1)-        else do-          mapM_ respond ms-          listen 0-    checkHandshake :: Int -> IO ()-    checkHandshake waits = do-      busses <- readMVar bussesMV-      when (null busses) $ do-        -- when (waits == 0) $ print "Waiting for SuperDirt (v.1.7.2 or higher).."-        sendHandshake-    respond :: O.Message -> IO ()-    respond (O.Message "/dirt/hello" _) = sendHandshake-    respond (O.Message "/dirt/handshake/reply" xs) = do-      prev <- swapMVar bussesMV $ bufferIndices xs-      return ()-    -- Only report the first time..-    -- when (null prev) $ print "Connected to SuperDirt."-    respond _ = return ()-    bufferIndices :: [O.Datum] -> [Int]-    bufferIndices [] = []-    bufferIndices (x : xs')-      | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'-      | otherwise = bufferIndices xs'--recvMessagesTimeout :: Double -> O.Udp -> IO [O.Message]-recvMessagesTimeout n sock = maybe [] O.packetMessages <$> recvPacketTimeout n sock
+ src/zwirn-core/Zwirn/Core/Cord.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Core.Cord where++{-+    Cord.hs - functions on parallel signals+    Copyright (C) 2025, 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 Zwirn.Core.Core+import Zwirn.Core.Time+import Zwirn.Core.Tree+import Zwirn.Core.Types++type Cord = ZwirnT Tree++liftList :: ([Tree (Value i a, st)] -> [Tree (Value i b, st)]) -> Cord st i a -> Cord st i b+liftList f = withInner g+  where+    g (Leaf x) = Branch $ f [Leaf x]+    g (Branch xs) = Branch $ f xs++liftListWithTimeState :: (Time -> st -> [Tree (Value i a, st)] -> [Tree (Value i b, st)]) -> Cord st i a -> Cord st i b+liftListWithTimeState f = withInnerTimeState g+  where+    g t st (Leaf x) = Branch $ f t st [Leaf x]+    g t st (Branch xs) = Branch $ f t st xs++instance HasSilence Tree where+  silence = zwirn $ const $ const $ Branch []++-- | group a list of cords+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+  where+    z t st = pure (Value l t [], st)+      where+        ts = unzwirn c t st+        l = topLength ts++-- | pick a certain layer out of a cord, wrapping around+_pick :: Int -> Cord st i a -> Cord st i a+_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++_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/Core.hs view
@@ -0,0 +1,133 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Core.Core where++{-+    Core.hs - core functions and instances+    Copyright (C) 2025, 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 Data.Bifunctor+import Zwirn.Core.Time+import Zwirn.Core.Types++-- | indicates the current time+now :: (Applicative k) => ZwirnT k st i Time+now = zwirn $ \t st -> pure (Value t t [], st)++modulateTime :: (a -> Time -> st -> Time) -> a -> ZwirnT k st i b -> ZwirnT k st i b+modulateTime f x b = zwirn (\t st -> unzwirn b (f x t st) st)++withInner :: (k (Value i a, st) -> k (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b+withInner f x = zwirn $ \t st -> f $ unzwirn x t st++withInnerAndTime :: (Time -> k (Value i a, st) -> k (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b+withInnerAndTime f x = zwirn $ \t st -> f t (unzwirn x t st)++withInnerTimeState :: (Time -> st -> k (Value i a, st) -> k (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b+withInnerTimeState f x = zwirn $ \t st -> f t st (unzwirn x t st)++withInner2 :: (k (Value i a, st) -> k (Value i b, st) -> k (Value i c, st)) -> ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c+withInner2 f x y = zwirn $ \t st -> f (unzwirn x t st) (unzwirn y t st)++withValueState :: (Functor k) => ((Value i a, st) -> (Value i b, st)) -> ZwirnT k st i a -> ZwirnT k st i b+withValueState f = withInner (fmap f)++withValue :: (Functor k) => (Value i a -> Value i b) -> ZwirnT k st i a -> ZwirnT k st i b+withValue f = withValueState (first f)++withA :: (Functor k) => (a -> a) -> ZwirnT k st i a -> ZwirnT k st i a+withA f = withValue (\v -> v {value = f $ value v})++withTime :: (Functor k) => (Time -> Time) -> ZwirnT k st i a -> ZwirnT k st i a+withTime f = withValue (\v -> v {time = f $ time v})++withInfo :: (Functor k) => (i -> i) -> ZwirnT k st i a -> ZwirnT k st i a+withInfo f = withValue (\v -> v {info = f <$> info v})++withInfos :: (Functor k) => ([i] -> [i]) -> ZwirnT k st i a -> ZwirnT k st i a+withInfos f = withValue (\v -> v {info = f $ info v})++addInfo :: (Functor k) => i -> ZwirnT k st i a -> ZwirnT k st i a+addInfo i = withInfos (const [i])++removeInfo :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i a+removeInfo = withInfos (const [])++withState :: (Functor k) => (st -> st) -> ZwirnT k st i a -> ZwirnT k st i a+withState f = withValueState (second f)++fromSignal :: (Applicative k) => (Time -> Time) -> ZwirnT k st i Time+fromSignal f = f <$> now++instance (Semigroup a, Applicative k) => Semigroup (ZwirnT k st i a) where+  (<>) = liftA2 (<>)++instance (Monoid a, Applicative k) => Monoid (ZwirnT k st i a) where+  mempty = pure mempty++instance (Functor k) => Functor (ZwirnT k st i) where+  fmap f = withInner (fmap $ first (fmap f))++instance (Applicative k) => Applicative (ZwirnT k st i) where+  pure x = zwirn $ \t st -> pure (Value x t [], st)+  liftA2 f = withInner2 (liftA2 (\(v1, st1) (v2, _) -> (liftA2 f v1 v2, st1)))++instance (MultiApplicative k) => MultiApplicative (ZwirnT k st i) where+  liftA2Left f = withInner2 (liftA2Left (\(v1, st1) (v2, _) -> (liftA2Left f v1 v2, st1)))+  liftA2Right f = withInner2 (liftA2Right (\(v1, st1) (v2, _) -> (liftA2Right f v1 v2, st1)))++instance (Monad k) => Monad (ZwirnT k st i) where+  (>>=) x f = _innerJoin $ fmap f x+    where+      _innerJoin pp = zwirn q+        where+          q t st = (\(z, st') -> first (mergeInfo (info z)) <$> unzwirn (value z) t st') =<< outer+            where+              outer = unzwirn pp t st+              mergeInfo i v = v {info = info v ++ i}++instance (MultiMonad k) => MultiMonad (ZwirnT k st i) where+  outerJoin pp = zwirn q+    where+      q t st = outerJoin $ (\(z, st') -> first (\v -> v {time = time z, info = info v ++ info z}) <$> unzwirn (value z) t st') <$> outer+        where+          outer = unzwirn pp t st++  squeezeJoin pp = zwirn q+    where+      q t st = squeezeJoin $ (\(z, st') -> first (mergeInfo (info z)) <$> unzwirn (value z) (time z) st') <$> outer+        where+          outer = unzwirn pp t st+          mergeInfo i v = v {info = info v ++ i}++squeezeMap :: (MultiMonad m) => (m a -> m b) -> m a -> m b+squeezeMap f x = squeezeJoin $ fmap (f . pure) x++enumerateFromByTo :: (Ord a, Num a) => a -> a -> a -> [a]+enumerateFromByTo x y z+  | y <= 0 = []+  | x == z = []+  | x < z = if z < x + y then [x] else x : enumerateFromByTo (x + y) y z+  | otherwise = if z > x - y then [x] else x : enumerateFromByTo (x - y) y z++enumerateFromThenTo :: (Ord a, Num a) => a -> a -> a -> [a]+enumerateFromThenTo x y+  | x <= y = enumerateFromByTo x (y - x)+  | otherwise = enumerateFromByTo x (x - y)++enumerateFromTo :: (Ord a, Num a) => a -> a -> [a]+enumerateFromTo x = enumerateFromByTo x 1
+ src/zwirn-core/Zwirn/Core/Lib/Conditional.hs view
@@ -0,0 +1,91 @@+module Zwirn.Core.Lib.Conditional where++{-+    Conditional.hs - conditional functions+    Copyright (C) 2025, 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 Data.Bifunctor (first)+import Data.Fixed (mod')+import Zwirn.Core.Lib.Core+import Zwirn.Core.Time+import Zwirn.Core.Types++ifthen :: (MultiMonad k) => ZwirnT k st i Bool -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+ifthen bz xz yz = innerJoin $ zwirn q+  where+    q t st = first (fmap f) <$> unzwirn bz t st+      where+        f True = xz+        f False = yz++iff :: (MultiMonad k, HasSilence k) => ZwirnT k st i Bool -> ZwirnT k st i a -> ZwirnT k st i a+iff b x = ifthen b x silence++or :: (Applicative k) => ZwirnT k st i Bool -> ZwirnT k st i Bool -> ZwirnT k st i Bool+or = liftA2 (||)++and :: (Applicative k) => ZwirnT k st i Bool -> ZwirnT k st i Bool -> ZwirnT k st i Bool+and = liftA2 (&&)++not :: (Functor k) => ZwirnT k st i Bool -> ZwirnT k st i Bool+not = fmap Prelude.not++eq :: (Eq a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i Bool+eq = liftA2 (==)++leq :: (Ord a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i Bool+leq = liftA2 (<=)++geq :: (Ord a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i Bool+geq = liftA2 (>=)++le :: (Ord a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i Bool+le = liftA2 (<)++ge :: (Ord a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i Bool+ge = liftA2 (>)++while :: (MultiMonad k) => ZwirnT k st i Bool -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+while b f x = ifthen b (apply f x) x++-- | the first value controls the period the second the length of applying the function in that period+everyFor :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+everyFor t1 t2 f x = (everyFor' <$> t1 <*> t2 <*> f) `innerApply` x+  where+    everyFor' 0 _ _ y = y+    everyFor' per for g y = zwirn $ \t st -> if mod' t per <= for then unzwirn (g y) t st else unzwirn y t st++-- | applies function every period for one cycle+every :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+every x = everyFor x (pure 1)++everyBeatShiftWith :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+everyBeatShiftWith bpcz shz nz fz xz = (everyBeatWith' <$> bpcz <*> shz <*> nz <*> fz) `innerApply` xz+  where+    everyBeatWith' :: Time -> Time -> Time -> (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+    everyBeatWith' _ _ 0 _ x = x+    everyBeatWith' 0 _ _ _ x = x+    everyBeatWith' bpc sh n f x = zwirn $ \t st -> if mod' (t + sh) (n / bpc) < (1 / bpc) then unzwirn (f x) t st else unzwirn x t st++everyBeatWith :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+everyBeatWith x = everyBeatShiftWith x (pure 0)++everyBeatShift :: (Monad k, State k st i) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+everyBeatShift = everyBeatShiftWith (realToFrac <$> beatsPerCycle)++everyBeat :: (Monad k, State k st i) => ZwirnT k st i Time -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+everyBeat = everyBeatShift (pure 0)
+ src/zwirn-core/Zwirn/Core/Lib/Cord.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Core.Lib.Cord where++{-+    Cord.hs - functions on parallel signals+    Copyright (C) 2025, 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.Monad (join)+import Data.Bifunctor (first)+import Zwirn.Core.Cord as C+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.Number+import Zwirn.Core.Time+import Zwirn.Core.Tree+import qualified Zwirn.Core.Tree as Tree+import Zwirn.Core.Types++-- | get the current depth of the cord+depth :: Cord st i a -> Cord st i Int+depth = C.depth++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]++ghostWith :: Cord st i Time -> Cord st i (Cord st i a -> Cord st i a) -> Cord st i a -> Cord st i a+ghostWith t f x = stack [shift (t * 2.5) $ apply f x, shift (t * 1.5) $ apply f x, x]++-- | pick a certain layer out of a cord, wrapping around+pick :: Cord st i Int -> Cord st i a -> Cord st i a+pick iz x = (_pick <$> iz) `innerApply` x++inhabit :: Cord st i Int -> Cord st i a -> Cord st i a+inhabit iz xz = zwirn q+  where+    q t st = innerJoin $ (\v -> look (value v) $ unzwirn xz (time v) st) . fst <$> ik+      where+        ik = unzwirn iz t st++-- | pick a certain layer out of a cord, silence when out of bounds+pick' :: Cord st i Int -> Cord st i a -> Cord st i a+pick' i x = (withInner . look' <$> i) `innerApply` x++-- | pick a certain layer out of a cord, wrapping around+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)++-- | insert cord a specific index+insert :: Cord st i Int -> Cord st i a -> Cord st i a -> Cord st i a+insert ic x y = flip ($ x) y . insert' =<< ic+  where+    insert' :: Int -> Cord st i a -> Cord st i a -> Cord st i a+    insert' i z ys = zwirn $ \t st -> insertT i (unzwirn z t st) (unzwirn ys t st)++-- | push to the top of the cord+push :: Cord st i a -> Cord st i a -> Cord st i a+push = withInner2 Tree.push++concat :: Cord st i a -> Cord st i a -> Cord st i a+concat = withInner2 Tree.concat++-- | remove the top of the cord+pop :: Cord st i a -> Cord st i a+pop = withInner Tree.pop++-- | remove cord at specific index+remove :: Cord st i Int -> Cord st i a -> Cord st i a+remove i x = (withInner . removeT <$> i) `innerApply` x++-- | apply function to specific index+at :: Cord st i Int -> Cord st i (Cord st i a -> Cord st i a) -> Cord st i a -> Cord st i a+at i f x = insert i (innerApply f $ pick i x) (remove i x)++applyCord :: (Num a) => Cord st i a -> Cord st i a -> Cord st i a+applyCord = liftA2Left (+)++reverse :: Cord st i a -> Cord st i a+reverse = liftList Prelude.reverse++rotate :: Cord st i Int -> Cord st i a -> Cord st i a+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))++take :: Cord st i Int -> Cord st i a -> Cord st i a+take iz xz = flip liftList xz . Prelude.take =<< iz++drop :: Cord st i Int -> Cord st i a -> Cord st i a+drop iz xz = flip liftList xz . Prelude.drop =<< iz++filter :: Cord st i (Cord st i a -> Cord st i Bool) -> Cord st i a -> Cord st i a+filter fz xz = iff bz xz+  where+    bz = cordmap fz xz++invert :: (Num a) => Cord st i a -> Cord st i a+invert = liftList invertList+  where+    invertList [] = []+    invertList (x : xs) = xs ++ [fmap (first $ fmap (+ 12)) x]++open :: (Num a) => Cord st i a -> Cord st i a+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))+      _ -> ds++expand :: (Num a) => Cord st i Int -> Cord st i a -> Cord st i a+expand iz xz = flip liftList xz . expandList =<< iz+  where+    expandList i ds = Prelude.take i $ concatMap (\x -> map (fmap $ first $ fmap (+ fromIntegral x)) ds) [0 :: Int, 12 ..]++enumFromToStack :: (Ord a, Num a) => Cord st i a -> Cord st i a -> Cord st i a+enumFromToStack xz yz = join $ en <$> xz <*> yz+  where+    en x y = stack $ map pure $ enumerateFromTo x y++enumFromThenToStack :: (Ord a, Num a) => Cord st i a -> Cord st i a -> Cord st i a -> Cord st i a+enumFromThenToStack xz yz zz = join $ en <$> xz <*> yz <*> zz+  where+    en x y z = stack $ map pure $ enumerateFromThenTo x y z++replicate :: Cord st i Int -> Cord st i a -> Cord st i a+replicate i x = (stack . flip Prelude.replicate x) =<< i++fold :: Cord st i (Cord st i a -> Cord st i (Cord st i a -> Cord st i a)) -> Cord st i a -> Cord st i a+fold fz xz = fold' fz =<< collect xz+  where+    fold' _ [] = silence+    fold' _ [x] = x+    fold' f (x : xs) = foldl' (\a b -> f `apply` a `apply` b) x xs++cordcat :: Cord st i a -> Cord st i a+cordcat x = fastcat =<< collect x++timerun :: Cord st i Time -> Cord st i Int+timerun tz = (fastcyclecatpat . flip zip (map pure [0 :: Int ..])) =<< collect tz++interpol :: Cord st i Time -> Cord st i Time+interpol x = _interpol =<< collect x++cordmap :: Cord st i (Cord st i a -> Cord st i b) -> Cord st i a -> Cord st i b+cordmap f x = (stack . map (apply f)) =<< collect x++layer :: Cord st i (Cord st i a -> Cord st i b) -> Cord st i a -> Cord st i b+layer f x = (stack . map (`apply` x)) =<< collect f++arp :: Cord st i a -> Cord st i a+arp x = apply (squeezeMap (pure . bump) ds) x+  where+    d = C.depth 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+echoWith cz tz fz xz = echoWith' =<< cz+  where+    echoWith' c = if c < 1 then silence else stack $ scanl (\ !prev _ -> apply fz $ shift tz prev) xz [0 .. c - 1]++followWith :: 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+followWith cz tz fz xz = followWith' =<< cz+  where+    followWith' c = if c < 1 then silence else stack $ scanl (\ !prev _ -> apply fz $ bump tz prev) xz [0 .. c - 1]
+ src/zwirn-core/Zwirn/Core/Lib/Core.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Core.Lib.Core where++{-+    Core.hs - core functions and instances+    Copyright (C) 2025, 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.Monad (join)+import Zwirn.Core.Core as C+import Zwirn.Core.Query+import Zwirn.Core.Time+import Zwirn.Core.Types++-- | indicates the current time+now :: (Applicative k) => ZwirnT k st i Time+now = C.now++-- | indicates the current cycle+cyc :: (Applicative k) => ZwirnT k st i Int+cyc = fmap floor C.now++trig :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Bool+trig = withValue (\(Value _ t i) -> Value (breakpointCondition 0.005 t) t i)++getInnerTime :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Double+getInnerTime = withValue (\v -> v {value = realToFrac $ tTime $ time v})++getSpeed :: (Functor k) => ZwirnT k st i a -> ZwirnT k st i Double+getSpeed = withValue (\v -> v {value = realToFrac $ tDiff $ time v})++apply :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i b) -> ZwirnT k st i a -> ZwirnT k st i b+apply = zipSqueezeApply++outerApply :: (MultiMonad m) => m (m a -> m b) -> m a -> m b+outerApply f x = outerJoin $ f <*> pure x++innerApply :: (Monad m) => m (m a -> m b) -> m a -> m b+innerApply f x = join $ f <*> pure x++squeezeApply :: (MultiMonad m) => m (m a -> m b) -> m a -> m b+squeezeApply f x = squeezeJoin $ f <*> pure x++zipApply :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i b) -> ZwirnT k st i a -> ZwirnT k st i b+zipApply fs x = zwirn q+  where+    q t st = innerJoin $ (\c -> unzwirn c t st) . ($ x) . value . fst <$> unzwirn fs t st++zipSqueezeApply :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i b) -> ZwirnT k st i a -> ZwirnT k st i b+zipSqueezeApply fs x = zwirn q+  where+    q t st = innerJoin $ func <$> unzwirn fs t st+      where+        func f = (\v -> unzwirn (value v x) (time v) st) $ fst f++matchApply :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i b) -> ZwirnT k st i a -> ZwirnT k st i b+matchApply fs x = innerJoin $ apply fs . pure <$> x++iterate :: (MultiMonad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+iterate nz fz xz = iterate' =<< nz+  where+    iterate' n = if n < 0 then silence else is !! n+      where+        is = Prelude.iterate (apply fz) xz++squeeze :: (MultiMonad m) => m (m a -> m b) -> m a -> m b+squeeze fp xp = squeezeJoin $ fmap (squeezeApply fp . pure) xp
+ src/zwirn-core/Zwirn/Core/Lib/Map.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Zwirn.Core.Lib.Map where++{-+    Map.hs - lifting functions on maps to signals, some adapted+    from https://github.com/tidalcycles/Tidal/blob/dev/src/Sound/Tidal/Control.hs+    Copyright (C) 2025, 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 Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.String (IsString)+import Zwirn.Core.Cord (Cord, stack)+import Zwirn.Core.Core+import Zwirn.Core.Lib.Cord (echoWith)+import Zwirn.Core.Lib.Core+import Zwirn.Core.Lib.Modulate (fastcat, slow)+import Zwirn.Core.Lib.Structure (run)+import Zwirn.Core.Time (Time)+import Zwirn.Core.Types+import Prelude hiding ((*>))++-- | create a singleton map with specific key+singleton :: (MultiApplicative m) => ZwirnT m st i k -> ZwirnT m st i a -> ZwirnT m st i (Map k a)+singleton = liftA2Right Map.singleton++-- | union of two maps, if a key exists in both, the value will come from the right+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)++-- | 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+  where+    fromLookup (Just x) = pure x+    fromLookup _ = silence++insert :: (Applicative m, Ord k) => ZwirnT m st i k -> ZwirnT m st i a -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)+insert k a m = Map.insert <$> k <*> a <*> m++-- | apply a function to a specific key, if key is absent, return the original map+fix :: (MultiMonad m, Ord k) => ZwirnT m st i k -> ZwirnT m st i (ZwirnT m st i a -> ZwirnT m st i a) -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)+fix kz fz mz = outerJoin $ fromLookup <$> lookupMaybe kz mz+  where+    fromLookup (Just x) = insert kz (apply fz (pure x)) mz+    fromLookup Nothing = mz+    lookupMaybe = liftA2Right Map.lookup++chop :: (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)+chop nz = squeezeMap (quickslice nz (run nz))++quickslice :: (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)+quickslice nz iz = squeezeMap (slice nz iz)++loopAt :: (Fractional a, IsString a, HasSilence m, Monad m, Ord k, IsString k) => ZwirnT m st i Time -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)+loopAt zt zx = (_loopAt <$> zt) `innerApply` zx+  where+    _loopAt 0 _ = silence+    _loopAt t x = Map.alter a "speed" . Map.insert "unit" "c" <$> slow (pure t) x+      where+        a (Just s) = Just (s / realToFrac t)+        a Nothing = Just (1 / realToFrac t)++slice :: (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)+slice 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, m]+      where+        b = fromMaybe 0 $ Map.lookup "begin" m+        e = fromMaybe 1 $ Map.lookup "end" 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++striateBy :: (Fractional a, Monad m, HasSilence m, Ord k, IsString k) => ZwirnT m st i Int -> ZwirnT m st i a -> ZwirnT m st i (Map k a) -> ZwirnT m st i (Map k a)+striateBy i f x = (_striateBy <$> i <*> f) `innerApply` x+  where+    _striateBy n g mz = fastcat $ map (offset . fromIntegral) [0 .. n - 1]+      where+        offset k = _mergePlayRange (slot * k, (slot * k) + g) <$> mz+        slot = (1 - g) / fromIntegral (n - 1)++striate :: (Fractional a, Monad 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)+striate i x = (_striate <$> i) `innerApply` x+  where+    _striate n z = fastcat $ map offset [0 .. n - 1]+      where+        offset k = _mergePlayRange (fromIntegral k / fromIntegral n, fromIntegral (k + 1) / fromIntegral n) <$> z++_mergePlayRange :: (Fractional a, Ord k, IsString k) => (a, a) -> Map k a -> Map k a+_mergePlayRange (b, e) cm = Map.insert "begin" ((b * d') + b') $ Map.insert "end" ((e * d') + b') cm+  where+    b' = fromMaybe 0 $ Map.lookup "begin" cm+    e' = fromMaybe 1 $ Map.lookup "end" cm+    d' = e' - b'++juxBy :: (Fractional a, Ord k, IsString k) => Cord st i a -> Cord st i (Cord st i (Map k a) -> Cord st i (Map k a)) -> Cord st i (Map k a) -> Cord st i (Map k a)+juxBy nz fz xz = stack [modifyPanL xz nz, modifyPanR (apply fz xz) nz]+  where+    modifyPanL = liftA2 (\x n -> Map.alter (pannerL n) "pan" x)+    modifyPanR = liftA2 (\x n -> Map.alter (pannerR n) "pan" x)+    pannerL n (Just p) = Just $ p + 0.5 + n / 2+    pannerL n Nothing = Just $ 0.5 + n / 2+    pannerR n (Just p) = Just $ p + 0.5 - n / 2+    pannerR n Nothing = Just $ 0.5 - n / 2++jux :: (Fractional a, Ord k, IsString k) => Cord st i (Cord st i (Map k a) -> Cord st i (Map k a)) -> Cord st i (Map k a) -> Cord st i (Map k a)+jux = juxBy (pure 1)++echo :: (Fractional a, Ord k, IsString k) => Cord st i Int -> Cord st i Time -> Cord st i a -> Cord st i (Map k a) -> Cord st i (Map k a)+echo cz tz ez = echoWith cz tz (pure (liftA2 (\e m -> Map.alter (modGain e) "gain" m) ez))+  where+    modGain e (Just g) = Just $ g * e+    modGain e Nothing = Just e
+ src/zwirn-core/Zwirn/Core/Lib/Modulate.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeApplications #-}++module Zwirn.Core.Lib.Modulate where++{-+    Modulate.hs - functions modulating time+    Copyright (C) 2025, 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 Data.Fixed (mod')+import Zwirn.Core.Core+import Zwirn.Core.Lib.Core+import Zwirn.Core.Time+import Zwirn.Core.Tree+import Zwirn.Core.Types++rev :: ZwirnT k st i a -> ZwirnT k st i a+rev = modulateTime (\_ t _ -> -t) ()++revBy :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+revBy tz x = (modulateTime (\y t _ -> fromIntegral @Int (floor y) + t - frac y) <$> tz) `innerApply` x++sini :: ZwirnT k st i a -> ZwirnT k st i a+sini = modulateTime (\_ t _ -> sin (2 * pi * t)) ()++fast :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+fast tz x = (modulateTime (\y t _ -> t * y) <$> tz) `innerApply` x++slow :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+slow tz x = (modulateTime timefunc <$> tz) `innerApply` x+  where+    timefunc y t _+      | y == 0 = 0+      | otherwise = t / y++shift :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+shift tz x = (modulateTime (\y t _ -> t - y) <$> tz) `innerApply` x++ply :: (MultiMonad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+ply tz = apply (matchApply ply' tz)+  where+    ply' = pure $ \t -> pure $ \x -> squeezeMap (fast t) x++bump :: (MultiMonad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+bump tz = apply (matchApply bump' tz)+  where+    bump' = pure $ \t -> pure $ \x -> squeezeMap (shift t) x++-- zoom into a specific region of time, while preserving the speed+zoom :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+zoom t1 t2 x = (modulateTime timefunc <$> tup) `innerApply` x+  where+    tup = liftA2 (,) t1 t2+    timefunc (st, en) t _+      | en > st = mod' (t * (en - st)) (en - st) + st+      | en == st = st+      | otherwise = st - mod' (t * (st - en)) (st - en)++-- loop a specific region of time, the shorter the region, the faster it gets+loop :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+loop t1 t2 x = (modulateTime timefunc <$> tup) `innerApply` x+  where+    tup = liftA2 (,) t1 t2+    timefunc (st, en) t _+      | en > st = mod' t (en - st) + st+      | en == st = st+      | otherwise = st - mod' t (st - en)++timeloop :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+timeloop = loop (pure 0)++loopfirst :: (Monad k) => ZwirnT k st i a -> ZwirnT k st i a+loopfirst = timeloop (pure 1)++ribbon :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+ribbon off len = loop off (liftA2 (+) off len)++swingBy :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a+swingBy t1 t2 x = (modulateTime timefunc <$> tup) `innerApply` x+  where+    tup = liftA2 (,) t1 t2+    timefunc (sh, segs) t _+      | odd (floor $ frac t * segs * 2 :: Int) = t - (sh / (segs * 2))+      | segs == 0 = 0+      | otherwise = t++----------------------------------------------+------------------ cats ----------------------+----------------------------------------------++fastcat :: (HasSilence k) => [ZwirnT k st i a] -> ZwirnT k st i a+fastcat [] = silence+fastcat 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 = frac scaledPhase + fromIntegral @Int cy++slowcat :: (HasSilence k, Monad k) => [ZwirnT k st i a] -> ZwirnT k st i a+slowcat zs = slow (pure $ fromIntegral $ length zs) $ fastcat zs++-- | each (t,p) indicates the amount of time t for pattern p relative+-- | to the other lengths in the list, squeezed within one cycle+timecat :: (HasSilence k, Monad k) => [(Time, ZwirnT k st i a)] -> ZwirnT k st i a+timecat tps = if total == 0 then silence else cyclecat normalised+  where+    total = sum $ map fst tps+    normalised = map (\(t, p) -> (t / total, slow (pure $ t / total) p)) tps++-- | each (t,p) indicates the amount of time t the pattern p is queried for+-- | the patterns in the list will be queried in order by their respective amounts+-- | Example: cyclecat [(1,pure 10), (2, slow 2 $ pure 20)] == < 10 20 ~ >+-- | Note: also works with rational numbers+cyclecat :: (HasSilence k) => [(Time, ZwirnT k st i a)] -> ZwirnT k st i a+cyclecat [] = silence+cyclecat xs = cyclecatrec xs (sum $ map fst xs)+  where+    -- len = sum $ map fst xs+    cyclecatrec [] _ = silence+    cyclecatrec [(_, p)] _ = p+    cyclecatrec (x : ys) !tot = cat x (tot - fst x, cyclecatrec ys (tot - fst x))++cat :: (HasSilence k) => (Time, ZwirnT k st i a) -> (Time, ZwirnT k st i a) -> ZwirnT k st i a+cat (t1, p1) (t2, p2) = if total == 0 then silence else zwirn q+  where+    total = t1 + t2+    q t = unzwirn item phase+      where+        cy = t / total+        first = frac cy < t1 / total+        item = if first then p1 else p2+        phase = if first then t - fromIntegral @Int (floor cy) * t2 else t - (fromIntegral @Int (floor cy) + 1) * t1++fastcyclecat :: (HasSilence k, Monad k) => [(Time, ZwirnT k st i a)] -> ZwirnT k st i a+fastcyclecat xs = cyclecat $ map (\(t, x) -> (t, slow (pure t) x)) xs++catpat :: (MultiMonad k, HasSilence k) => (ZwirnT k st i Time, ZwirnT k st i a) -> (ZwirnT k st i Time, ZwirnT k st i a) -> ZwirnT k st i a+catpat (t1z, p1) (t2z, p2) = innerJoin $ liftA2 (\t1 t2 -> cat (t1, p1) (t2, p2)) t1z t2z++cyclecatpat :: (MultiMonad k, HasSilence k) => [(ZwirnT k st i Time, ZwirnT k st i a)] -> ZwirnT k st i a+cyclecatpat [] = silence+cyclecatpat xs = cyclecatrec xs (foldl' (liftA2 (+)) (pure 0) $ map fst xs)+  where+    cyclecatrec [] _ = silence+    cyclecatrec [(_, p)] _ = p+    cyclecatrec (x : ys) !tot = catpat x (newTot, cyclecatrec ys newTot)+      where+        newTot = liftA2 (-) tot (fst x)++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
+ src/zwirn-core/Zwirn/Core/Lib/Number.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Core.Lib.Number where++{-+    Number.hs - lifting functions on numbers to signals+    Copyright (C) 2025, 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 Data.Fixed (mod')+import Zwirn.Core.Core+import Zwirn.Core.Lib.Modulate (cat, fastcat)+import Zwirn.Core.Time (Time)+import Zwirn.Core.Types++instance (Num a, Applicative k) => Num (ZwirnT k st i a) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  (*) = liftA2 (*)+  negate = fmap negate+  abs = fmap abs+  signum = fmap signum+  fromInteger = pure . fromInteger++instance (Eq a, Fractional a, MultiMonad k, HasSilence k) => Fractional (ZwirnT k st i a) where+  fromRational = pure . fromRational+  recip xz = innerJoin $ fmap (\x -> if x == 0 then silence else pure $ recip x) xz++instance (Ord a, Floating a, MultiMonad k, HasSilence k) => Floating (ZwirnT k st i a) where+  pi = pure pi+  exp = fmap exp+  log xz = innerJoin $ fmap (\x -> if x <= 0 then silence else pure $ log x) xz+  sqrt xz = innerJoin $ fmap (\x -> if x < 0 then silence else pure $ sqrt x) xz+  (**) xz yz = innerJoin $ liftA2 (\x y -> if x <= 0 && abs y < 1 then silence else pure $ x ** y) xz yz+  logBase bz xz = innerJoin $ liftA2 (\b x -> if b < 0 || x <= 0 then silence else pure $ logBase b x) bz xz+  sin = fmap sin+  cos = fmap cos+  tan = fmap tan+  asin = fmap asin+  acos = fmap acos+  atan = fmap atan+  sinh = fmap sinh+  cosh = fmap cosh+  tanh = fmap tanh+  asinh = fmap asinh+  acosh = fmap acosh+  atanh = fmap atanh++mod :: (Real a, HasSilence k, MultiMonad k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+mod xz yz = innerJoin $ liftA2 (\x y -> if y == 0 then silence else pure $ mod' x y) xz yz++frac :: (Real a, MultiMonad k) => ZwirnT k st i a -> ZwirnT k st i a+frac = fmap (`mod'` 1)++trunc :: (RealFrac a, Integral b, Functor k) => ZwirnT k st i a -> ZwirnT k st i b+trunc = fmap truncate++ceil :: (RealFrac a, Integral b, Functor k) => ZwirnT k st i a -> ZwirnT k st i b+ceil = fmap ceiling++floor :: (RealFrac a, Integral b, Functor k) => ZwirnT k st i a -> ZwirnT k st i b+floor = fmap Prelude.floor++round :: (RealFrac a, Integral b, Functor k) => ZwirnT k st i a -> ZwirnT k st i b+round = fmap Prelude.round++gcd :: (Integral a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+gcd = liftA2 Prelude.gcd++lcm :: (Integral a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+lcm = liftA2 Prelude.lcm++range :: (Num a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+range lx lu lv = (\l u v -> (1 - v) * l + v * u) <$> lx <*> lu <*> lv++sine :: (Applicative k) => ZwirnT k st i Time+sine = fromSignal (\t -> (sin (2 * pi * t) + 1) / 2)++sine2 :: (Applicative k) => ZwirnT k st i Time+sine2 = fromSignal (\t -> sin (2 * pi * t))++cosine :: (Applicative k) => ZwirnT k st i Time+cosine = fromSignal (\t -> (cos (2 * pi * t) + 1) / 2)++cosine2 :: (Applicative k) => ZwirnT k st i Time+cosine2 = fromSignal (\t -> cos (2 * pi * t))++saw :: (Applicative k) => ZwirnT k st i Time+saw = fromSignal (`mod'` 1)++saw2 :: (Applicative k) => ZwirnT k st i Time+saw2 = fromSignal (\t -> (mod' t 1 * 2) - 1)++isaw :: (Applicative k) => ZwirnT k st i Time+isaw = fromSignal (\t -> 1 - mod' t 1)++isaw2 :: (Applicative k) => ZwirnT k st i Time+isaw2 = fromSignal (\t -> 1 - (mod' t 1 * 2))++square :: (Applicative k) => ZwirnT k st i Time+square = fromSignal (\t -> fromIntegral @Int $ Prelude.floor $ mod' t 1 * 2)++square2 :: (Applicative k) => ZwirnT k st i Time+square2 = fromSignal (\t -> fromIntegral @Int $ Prelude.floor (mod' t 1 * 2) - 1)++tri :: (Applicative k, HasSilence k) => ZwirnT k st i Time+tri = fastcat [saw, isaw]++tri2 :: (Applicative k, HasSilence k) => ZwirnT k st i Time+tri2 = fastcat [saw2, isaw2]++firstCyclesThen :: (Monad k) => ZwirnT k st i Time -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+firstCyclesThen t1 dz xz = func =<< t1+  where+    func l = zwirn q+      where+        q t st = if t <= l then unzwirn xz t st else unzwirn dz t st++linear :: (Applicative k) => ZwirnT k st i Time -> ZwirnT k st i Time -> ZwirnT k st i Time+linear x y = range x y saw++_interpol :: (Applicative k, HasSilence k) => [ZwirnT k st i Time] -> ZwirnT k st i Time+_interpol [] = silence+_interpol [x] = x+_interpol (x : y : zs) = if null zs then linear x y else cat (delta, l) (1 - delta, ls)+  where+    delta = 1 / (fromIntegral (length zs) + 1)+    l = linear x y+    ls = _interpol (y : zs)
+ src/zwirn-core/Zwirn/Core/Lib/Random.hs view
@@ -0,0 +1,153 @@+module Zwirn.Core.Lib.Random where++{-+    Random.hs - simple random signals and related functions+    Copyright (C) 2025, 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.Monad (join)+import qualified Numeric.Noise as Noise+import System.Random+import Zwirn.Core.Core+import Zwirn.Core.Lib.Core+import Zwirn.Core.Lib.Modulate+import Zwirn.Core.Time (Time)+import Zwirn.Core.Types++precision :: Time+precision = 0.005++randR :: (Random a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+randR l r = zwirn q+  where+    q t = unzwirn (fmap fst $ liftA2 randomR zipp $ pure $ mkStdGen $ floor (t / precision)) t+      where+        zipp = liftA2 (,) l r++rand :: (Random a, Applicative k) => ZwirnT k st i a+rand = zwirn $ \t st -> pure (Value (fst $ random (mkStdGen $ floor (t / precision))) t [], st)++noise :: (Applicative k) => ZwirnT k st i Double+noise = rand++irand :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int+irand = randR (pure 0)++brandBy :: (Applicative k) => ZwirnT k st i Double -> ZwirnT k st i Bool+brandBy prob = liftA2 (>) prob rand++sometimesBy :: (MultiMonad k) => ZwirnT k st i Double -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+sometimesBy prob f x = innerJoin $ fmap cho (brandBy prob)+  where+    cho True = apply f x+    cho False = x++sometimes :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+sometimes = sometimesBy (pure 0.5)++often :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+often = sometimesBy (pure 0.75)++rarely :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+rarely = sometimesBy (pure 0.25)++almostNever :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+almostNever = sometimesBy (pure 0.1)++almostAlways :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+almostAlways = sometimesBy (pure 0.9)++-- TODO: FIX+degradeBy :: (MultiMonad k, HasSilence k) => ZwirnT k st i Double -> ZwirnT k st i a -> ZwirnT k st i a+degradeBy prob = sometimesBy prob (pure $ const silence)++degrade :: (MultiMonad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a+degrade = sometimes (pure $ const silence)++-- these versions take the cycle number as seed++randR' :: (Random a, Applicative k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+randR' r l = zwirn q+  where+    q t = unzwirn (fmap fst $ liftA2 randomR zipp $ pure $ mkStdGen $ floor t) t+      where+        zipp = liftA2 (,) l r++rand' :: (Random a, Applicative k) => ZwirnT k st i a+rand' = zwirn $ \t st -> pure (Value (fst $ random (mkStdGen $ floor t)) t [], st)++irand' :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int+irand' = randR' (pure 0)++brandBy' :: (Applicative k) => ZwirnT k st i Double -> ZwirnT k st i Bool+brandBy' prob = liftA2 (>) prob rand'++somecyclesBy :: (MultiMonad k) => ZwirnT k st i Double -> ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+somecyclesBy prob f x = innerJoin $ fmap cho (brandBy' prob)+  where+    cho True = apply f x+    cho False = x++somecycles :: (MultiMonad k) => ZwirnT k st i (ZwirnT k st i a -> ZwirnT k st i a) -> ZwirnT k st i a -> ZwirnT k st i a+somecycles = somecyclesBy (pure 0.5)++------++chooseWithSeed :: (Monad k) => Int -> [ZwirnT k st i a] -> ZwirnT k st i a+chooseWithSeed i ps = (ps !!) =<< shift (pure $ fromIntegral i / precision) (irand' $ pure $ length ps - 1)++chooseList :: (Monad k) => [ZwirnT k st i a] -> ZwirnT k st i a+chooseList = chooseWithSeed 0++enumFromToChoice :: (Ord a, Num a, Monad k) => Int -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+enumFromToChoice i xz yz = join $ en <$> xz <*> yz+  where+    en x y = chooseWithSeed i $ map pure $ enumerateFromTo x y++enumFromThenToChoice :: (Ord a, Num a, Monad k) => Int -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+enumFromThenToChoice i xz yz zz = join $ en <$> xz <*> yz <*> zz+  where+    en x y z = chooseWithSeed i $ map pure $ enumerateFromThenTo x y z++perlinSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double+perlinSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.perlin2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st++perlin :: (Applicative k) => ZwirnT k st i Double+perlin = perlinSeed (pure 0)++simplexSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double+simplexSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.openSimplex2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st++simplex :: (Applicative k) => ZwirnT k st i Double+simplex = simplexSeed (pure 0)++ssimplexSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double+ssimplexSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.superSimplex2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st++ssimplex :: (Applicative k) => ZwirnT k st i Double+ssimplex = ssimplexSeed (pure 0)++valueSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double+valueSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.value2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st++valueN :: (Applicative k) => ZwirnT k st i Double+valueN = valueSeed (pure 0)++cubicSeed :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Double+cubicSeed seed = zwirn $ \t st -> unzwirn ((\i -> (Noise.noise2At Noise.valueCubic2 (fromIntegral i) 0 (realToFrac t) + 1) / 2) <$> seed) t st++cubic :: (Applicative k) => ZwirnT k st i Double+cubic = cubicSeed (pure 0)
+ src/zwirn-core/Zwirn/Core/Lib/State.hs view
@@ -0,0 +1,52 @@+module Zwirn.Core.Lib.State where++{-+    State.hs - functions manipulating the underlying state of signals+    Copyright (C) 2025, 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 qualified Data.Map as Map+import Zwirn.Core.Core+import Zwirn.Core.Lib.Core+import Zwirn.Core.Types++--- functions modifying the state++modify' :: (st -> st) -> ZwirnT k st i a -> ZwirnT k st i a+modify' f x = zwirn $ \t st -> unzwirn x t (f st)++modify :: (MultiMonad k) => (ZwirnT k st i st -> ZwirnT k st i st) -> ZwirnT k st i a -> ZwirnT k st i a+modify f x = set (f (get x)) x++get :: (Applicative k) => ZwirnT k st i a -> ZwirnT k st i st+get = withValueState (\(v, st) -> (fmap (const st) v, st))++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++-- functions to act on state that is a map++-- | get value of specific key, providing a function in case key is not found+getMap :: (MultiMonad k, Ord key) => (Maybe b -> ZwirnT k (Map.Map key b) i b) -> ZwirnT k (Map.Map key b) i key -> ZwirnT k (Map.Map key b) i b+getMap fromLookup xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))++-- | set value of given key+setMap :: (Monad k, Ord key) => ZwirnT k (Map.Map key b) i key -> ZwirnT k (Map.Map key b) i b -> ZwirnT k (Map.Map key b) i a -> ZwirnT k (Map.Map key b) i a+setMap key b = set (liftA2 Map.insert key b <*> get (pure ()))++-- | modify+modifyMap :: (MultiMonad k, Ord key) => (Maybe b -> ZwirnT k (Map.Map key b) i b) -> ZwirnT k (Map.Map key b) i key -> (ZwirnT k (Map.Map key b) i b -> ZwirnT k (Map.Map key b) i b) -> ZwirnT k (Map.Map key b) i a -> ZwirnT k (Map.Map key b) i a+modifyMap fromLookup key f = setMap key (f (getMap fromLookup key))
+ src/zwirn-core/Zwirn/Core/Lib/Structure.hs view
@@ -0,0 +1,228 @@+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# HLINT ignore "Use tuple-section" #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++module Zwirn.Core.Lib.Structure where++{-+    Structure.hs - functions manipulating the 'structure' of signals+    Copyright (C) 2025, 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.Applicative+import Control.Monad (join)+import Data.List (mapAccumL)+import Music.Theory.Bjorklund (bjorklund, iseq)+import Numeric (showIntAtBase)+import Text.ParserCombinators.ReadP+import Zwirn.Core.Core+import Zwirn.Core.Lib.Core+import Zwirn.Core.Lib.Modulate+import Zwirn.Core.Time+import Zwirn.Core.Tree hiding (concat)+import Zwirn.Core.Types+import Prelude hiding (enumFromTo)++runFromTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+runFromTo xz yz = join $ en <$> xz <*> yz+  where+    en x y = fastcat $ map pure $ enumerateFromTo x y++runFromThenTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+runFromThenTo xz yz zz = join $ en <$> xz <*> yz <*> zz+  where+    en x y z = fastcat $ map pure $ enumerateFromThenTo x y z++slowrunFromTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+slowrunFromTo xz yz = join $ en <$> xz <*> yz+  where+    en x y = slowcat $ map pure $ enumerateFromTo x y++slowrunFromThenTo :: (Ord a, Num a, Monad k, HasSilence k) => ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a -> ZwirnT k st i a+slowrunFromThenTo xz yz zz = join $ en <$> xz <*> yz <*> zz+  where+    en x y z = slowcat $ map pure $ enumerateFromThenTo x y z++run :: (Monad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i Int+run = runFromTo (pure 0)++slowrun :: (Monad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i Int+slowrun = slowrunFromTo (pure 0)++sampleAndHold :: (MultiMonad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a+sampleAndHold iz az = segment iz $ innerJoin $ sampleAndHold' <$> iz+  where+    sampleAndHold' i+      | i <= 0 = silence+      | otherwise = zwirn q+      where+        q t = unzwirn az (fromIntegral (floor $ tTime t * fromIntegral i) / fromIntegral i)++-- struct combines the inner time (structure) of the first argument with the values of the second one+-- this function does not 'sample and hold' like in tidal/strudel+struct :: (MultiMonad k) => ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i b+struct = withInner2 (liftA2Both f)+  where+    f (v1, st) (v2, _) = (Value (value v2) (time v1) (info v1), st)++segment :: (MultiMonad k, HasSilence k) => ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a+segment = struct . run++euclidOff :: (HasSilence k, Monad k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a+euclidOff i1 i2 i3 x = (euclidOff' <$> i1 <*> i2 <*> i3) `innerApply` x+  where+    euclidOff' a b off y = timecat $ map (\i -> (fromIntegral i :: Time, y)) ts+      where+        ts = rot off $ iseq $ bjorklund (a, b)+        rot n xs = take lxs . drop ((-n) `mod` lxs) . cycle $ xs where lxs = length xs++euclid :: (HasSilence k, Monad k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i a -> ZwirnT k st i a+euclid x y = euclidOff x y (pure 0)++left :: (MultiMonad k) => (ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c) -> ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c+left f x y = struct x $ f x y++right :: (MultiMonad k) => (ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c) -> ZwirnT k st i a -> ZwirnT k st i b -> ZwirnT k st i c+right f x y = struct y $ f x y++euclidean :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i String+euclidean i1 i2 i3 = euclidean' <$> i1 <*> i2 <*> i3+  where+    euclidean' off a b = map toChar $ rotateList off $ bjorklund (a, b)+    toChar True = '1'+    toChar False = '0'++-------------------------------------------+----------- chunking notation -------------+-------------------------------------------++-- see Computational Models of Rhythm and Meter by Georg Boenn+-- nested chunks via [...]+-- they will occupy one unit (i.e. one eighth by default) with their duration subdived by the amount of steps within+-- example: [i] == eight triplet, [~!] == rhythm in quintuplets etc.++type Sequence = Tree Bool++singleChunk :: Char -> [Bool]+singleChunk '~' = [False]+singleChunk '.' = [True]+singleChunk '0' = [False]+singleChunk '1' = [True]+singleChunk 'I' = [True, False]+singleChunk ':' = [True, True]+singleChunk 'v' = [False, True]+singleChunk '-' = [True, False, False]+singleChunk '<' = [False, True, False]+singleChunk 'w' = [False, False, True]+singleChunk 'X' = [True, True, False]+singleChunk '>' = [True, False, True]+singleChunk '+' = [False, True, True]+singleChunk 'i' = [True, True, True]+singleChunk 'H' = [True, False, False, False]+singleChunk '!' = [True, True, False, False]+singleChunk _ = []++pChunk :: ReadP [Sequence]+pChunk = do+  c <- get+  if c == '[' then pfail else return $ map Leaf $ singleChunk c++pChunks :: ReadP [Sequence]+pChunks = do+  _ <- char '['+  xs <- manyTill (pChunks +++ pChunk) (char ']')+  return [Branch $ concat xs]++pOuterChunks :: ReadP [Sequence]+pOuterChunks = concat <$> many1 (pChunks +++ pChunk)++runChunk :: String -> Maybe [Sequence]+runChunk s = case map fst $ filter (\(_, x) -> null x) $ readP_to_S pOuterChunks s of+  (x : _) -> Just x+  _ -> Nothing++seqToZwirn :: (HasSilence k, Monad k) => Sequence -> Int -> ZwirnT k st i Int+seqToZwirn t shif = seqToZwirnNum shif $ numberedTreeBool t+  where+    seqToZwirnNum sh (Leaf (i, True)) = pure $ i + sh+    seqToZwirnNum _ (Leaf (_, False)) = silence+    seqToZwirnNum _ (Branch []) = silence+    seqToZwirnNum sh (Branch xs) = fastcyclecat $ map (\x -> (1 / fromIntegral (length xs), seqToZwirnNum sh x)) xs++chunkWith :: (HasSilence k, MultiMonad k) => ZwirnT k st i Double -> ZwirnT k st i String -> ZwirnT k st i Int+chunkWith m s = innerJoin $ fullChunk' <$> m <*> s+  where+    fullChunk' d i = case runChunk i of+      Nothing -> silence+      Just ss -> if d == 0 then silence else fastcyclecat $ snd $ mapAccumL (\k se -> (k + countTrue se, (1 / realToFrac d, seqToZwirn se k))) 0 ss+        where+          countTrue (Leaf False) = 0+          countTrue (Leaf True) = 1+          countTrue (Branch xs) = sum (map countTrue xs)++chunk :: (HasSilence k, MultiMonad k, State k st i) => ZwirnT k st i String -> ZwirnT k st i Int+chunk = chunkWith beatsPerCycle++chunked :: (HasSilence k, MultiMonad k, State k st i) => ZwirnT k st i String -> ZwirnT k st i a -> ZwirnT k st i a+chunked = struct . chunk++binary :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i String+binary = fmap (\i -> showIntAtBase 2 sel i "")+  where+    sel 0 = '0'+    sel _ = '1'++christoffelWord :: Int -> Int -> String+christoffelWord m n = snd $ foldl (christoffelWord' m n) (0, "") [1 .. n]+  where+    christoffelWord' :: Int -> Int -> (Int, String) -> Int -> (Int, String)+    christoffelWord' k l (prev, out) i = (y, out ++ "1" ++ bs)+      where+        y = floor $ fromIntegral i * fromIntegral k / fromIntegral l+        test = y - prev+        bs = replicate test '0'++christoffel :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i Int -> ZwirnT k st i String+christoffel m n = christoffelWord <$> m <*> n++rotate :: (Applicative k) => ZwirnT k st i Int -> ZwirnT k st i [a] -> ZwirnT k st i [a]+rotate i xs = rotateList <$> i <*> xs++rotateList :: Int -> [a] -> [a]+rotateList n xs = take lxs . drop ((-n) `mod` lxs) . cycle $ xs+  where+    lxs = length xs++neg :: (Applicative k) => ZwirnT k st i String -> ZwirnT k st i String+neg = fmap neg'+  where+    neg' ('0' : xs) = '1' : neg' xs+    neg' ('1' : xs) = '0' : neg' xs+    neg' ('~' : xs) = '.' : neg' xs+    neg' ('.' : xs) = '~' : neg' xs+    neg' ('I' : xs) = 'v' : neg' xs+    neg' ('v' : xs) = 'I' : neg' xs+    neg' (':' : xs) = '~' : '~' : neg' xs+    neg' ('-' : xs) = '+' : neg' xs+    neg' ('+' : xs) = '-' : neg' xs+    neg' ('>' : xs) = '<' : neg' xs+    neg' ('<' : xs) = '>' : neg' xs+    neg' ('w' : xs) = 'X' : neg' xs+    neg' ('X' : xs) = 'w' : neg' xs+    neg' ('i' : xs) = '~' : '~' : '~' : neg' xs+    neg' ('H' : xs) = '~' : 'i' : neg' xs+    neg' ('!' : xs) = '~' : '+' : neg' xs+    neg' ys = ys
+ src/zwirn-core/Zwirn/Core/Lib/Text.hs view
@@ -0,0 +1,29 @@+module Zwirn.Core.Lib.Text where++{-+    Text.hs - lifting functions on text to signals+    Copyright (C) 2025, 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 qualified Data.Text as T+import Zwirn.Core.Core ()+import Zwirn.Core.Types++append :: (MultiApplicative k) => ZwirnT k st i T.Text -> ZwirnT k st i T.Text -> ZwirnT k st i T.Text+append = liftA2Left T.append++length :: (Functor k) => ZwirnT k st i T.Text -> ZwirnT k st i Int+length = fmap T.length
+ src/zwirn-core/Zwirn/Core/Query.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Zwirn.Core.Query where++{-+    Query.hs - querying signals for breakpoints+    (i.e. the zeroes of the fractional part of the inner time of a signal)+    Copyright (C) 2025, 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 Data.List (uncons)+import Zwirn.Core.Time+import Zwirn.Core.Tree hiding (concat)+import Zwirn.Core.Types++type Breakpoint st i a = (Time, Value i a, st)++instance (Show a, Num st, ToList k) => Show (ZwirnT k st i a) where+  show = show . findAllValuesWithTime (Time 0 1, Time 1 1) 0++findAllValuesWithTime :: (ToList k) => (Time, Time) -> st -> ZwirnT k st i a -> [(Time, a)]+findAllValuesWithTime = findAllValuesWithTimePrec 0.005++findAllValuesWithTimeState :: (ToList k) => (Time, Time) -> st -> ZwirnT k st i a -> ([(Time, a)], st)+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+  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')+  where+    (xs, st') = findAllBreakpoints prec start end st z++checkBreakpoint :: (ToList k) => Time -> Time -> st -> ZwirnT k st i a -> ([Breakpoint st i a], st)+checkBreakpoint !prec !now st z = (concatMap func vs, newst)+  where+    vs = toList $ unzwirn z now st+    func (v, _) = [(now, v, st) | breakpointCondition prec (time v)]+    newst = case uncons vs of+      (Just ((_, st'), _)) -> st'+      Nothing -> st++breakpointCondition :: Time -> Time -> Bool+breakpointCondition prec (Time !t !diff)+  | diff > 0 = frac t / diff < tTime prec+  | diff == 0 = False+  | otherwise = frac (abs t) / abs diff < tTime prec++findAllBreakpoints :: (ToList k) => Time -> Time -> Time -> st -> ZwirnT k st i a -> ([Breakpoint st i a], st)+findAllBreakpoints prec !now end initialSt z = go [] now initialSt+  where+    !limit = end - prec+    go acc !t !st+      | t > limit = (reverse acc, st)+      | otherwise = case checkBreakpoint prec t st z of+          ([], st') -> go acc (t + prec) st'+          (bps, newst) -> go (reverse bps ++ acc) (t + prec) newst
+ src/zwirn-core/Zwirn/Core/Time.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Zwirn.Core.Time where++{-+    Time.hs - automated differentiation for time+    Copyright (C) 2025, 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/>.+-}++data Time+  = Time {tTime :: !Rational, tDiff :: !Rational}+  deriving (Eq, Ord)++instance Show Time where+  show (Time x _) = show x++showAll :: Time -> String+showAll (Time x y) = "(" ++ show x ++ "," ++ show y ++ ")"++instance Num Time where+  Time x x' + Time y y' = Time (x + y) (x' + y')+  Time x x' * Time y y' = Time (x * y) (y' * x + x' * y)+  fromInteger x = Time (fromInteger x) 0+  negate (Time x x') = Time (negate x) (negate x')+  signum (Time x _) = Time (signum x) 0+  abs (Time x x') = Time (abs x) (x' * signum x)++instance Enum Time where+  toEnum i = Time (fromIntegral i) 0+  fromEnum (Time i _) = fromEnum i++instance Fractional Time where+  fromRational x = Time x 0+  recip (Time x x') = Time (recip x) (-(x' / x * x))++instance Real Time where+  toRational (Time x _) = x++instance RealFrac Time where+  properFraction (Time x x') = (i, Time p x')+    where+      (i, p) = properFraction x++instance Floating Rational where+  pi = toRational pi+  exp = toRational . exp . fromRational+  log = toRational . log . fromRational+  sin = toRational . sin . fromRational+  cos = toRational . cos . fromRational+  asin = toRational . asin . fromRational+  acos = toRational . acos . fromRational+  atan = toRational . atan . fromRational+  sinh = toRational . sinh . fromRational+  cosh = toRational . cosh . fromRational+  asinh = toRational . asinh . fromRational+  acosh = toRational . acosh . fromRational+  atanh = toRational . atanh . fromRational++instance Floating Time where+  pi = Time pi 0+  exp (Time x x') = Time (exp x) (x' * exp x)+  log (Time x x') = Time (log x) (x' / x)+  sqrt (Time x x') = Time (sqrt x) (x' / (2 * sqrt x))+  sin (Time x x') = Time (sin x) (x' * cos x)+  cos (Time x x') = Time (cos x) (x' * (-sin x))+  asin (Time x x') = Time (asin x) (x' / sqrt (1 - x * x))+  acos (Time x x') = Time (acos x) (x' / (-sqrt (1 - x * x)))+  atan (Time x x') = Time (atan x) (1 / ((x' * x') + 1))+  sinh (Time x x') = Time (sinh x) (cosh x')+  cosh (Time x x') = Time (cosh x) (sinh x')+  asinh (Time x x') = Time (asinh x) (1 / sqrt ((x' * x') + 1))+  acosh (Time x x') = Time (acosh x) (1 / sqrt (x' - 1) * sqrt (x' + 1))+  atanh (Time x x') = Time (atanh x) (1 / (1 - (x' * x')))
+ src/zwirn-core/Zwirn/Core/Tree.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}++module Zwirn.Core.Tree where++{-+    Tree.hs - a structure for parallel signals+    Copyright (C) 2025, 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 Data.Fixed (mod')+import Zwirn.Core.Types++nth :: (RealFrac r) => r -> [a] -> a+nth = wrapAt++wrapAt :: (RealFrac r) => r -> [a] -> a+wrapAt t ls = ls !! phase+  where+    phase = mod (floor t) (length ls)++frac :: (Real r) => r -> r+frac d = mod' d 1++data Tree a+  = Leaf a+  | Branch [Tree a]+  deriving (Show, Eq, Functor)++instance ToList Tree where+  toList (Leaf a) = [a]+  toList (Branch as) = concatMap toList as++(!!!) :: (RealFrac b) => [a] -> b -> a+(!!!) as r = nth r as++empty :: Tree a+empty = Branch []++isEmpty :: Tree a -> Bool+isEmpty (Leaf _) = False+isEmpty (Branch ts) = all isEmpty ts++singleton :: a -> Tree a+singleton = Leaf++fromList :: [a] -> Tree a+fromList as = Branch $ map singleton as++look :: Int -> Tree a -> Tree a+look _ (Leaf x) = Leaf x+look _ (Branch []) = empty+look i (Branch xs) = xs !!! fromIntegral i++look' :: Int -> Tree a -> Tree a+look' 0 (Leaf x) = Leaf x+look' _ (Leaf _) = empty+look' i (Branch xs) = if length xs > i && i >= 0 then xs !! i else empty++lookup :: [Int] -> Tree a -> Tree a+lookup is x = foldl (flip look) x is++concatMapTree :: (a -> Tree b) -> Tree a -> Tree b+concatMapTree f x = squeezeJoin $ fmap f x++topLength :: Tree a -> Int+topLength (Leaf _) = 1+topLength (Branch xs) = length xs++push :: Tree a -> Tree a -> Tree a+push x l@(Leaf _) = Branch [l, x]+push x (Branch xs) = Branch (xs ++ [x])++concat :: Tree a -> Tree a -> Tree a+concat l1@(Leaf _) l2@(Leaf _) = Branch [l1, l2]+concat l@(Leaf _) (Branch xs) = Branch (l : xs)+concat (Branch xs) l@(Leaf _) = Branch (xs ++ [l])+concat (Branch xs) (Branch ys) = Branch (xs ++ ys)++pop :: Tree a -> Tree a+pop (Leaf _) = empty+pop (Branch []) = empty+pop (Branch xs) = Branch (take (length xs - 1) xs)++insertT :: Int -> Tree a -> Tree a -> Tree a+insertT 0 x (Leaf y) = Branch [x, Leaf y]+insertT _ x (Leaf y) = Branch [Leaf y, x]+insertT i x (Branch ys) = Branch (ys1 ++ [x] ++ ys2)+  where+    (ys1, ys2) = splitAt i ys++removeT :: Int -> Tree a -> Tree a+removeT _ (Leaf _) = empty+removeT i (Branch xs) = case splitAt i xs of+  (xs1, []) -> Branch xs1+  (xs1, _ : xs2) -> Branch $ xs1 ++ xs2++numberedTree :: Tree a -> Tree (Int, a)+numberedTree = snd . numberedTreeRec 0+  where+    numberedTreeRec :: Int -> Tree a -> (Int, Tree (Int, a))+    numberedTreeRec n (Leaf x) = (n + 1, Leaf (n, x))+    numberedTreeRec n (Branch []) = (n, Branch [])+    numberedTreeRec n (Branch (x : xs)) = (fst $ last fs, Branch $ map snd fs)+      where+        l = numberedTreeRec n x+        fs = foldl' folder [l] xs+        folder is t = is ++ [numberedTreeRec m t]+          where+            m = fst $ last is++numberedTreeBool :: Tree Bool -> Tree (Int, Bool)+numberedTreeBool = snd . numberedTreeRec 0+  where+    numberedTreeRec :: Int -> Tree Bool -> (Int, Tree (Int, Bool))+    numberedTreeRec n (Leaf True) = (n + 1, Leaf (n, True))+    numberedTreeRec n (Leaf False) = (n, Leaf (n, False))+    numberedTreeRec n (Branch []) = (n, Branch [])+    numberedTreeRec n (Branch (x : xs)) = (fst $ last fs, Branch $ map snd fs)+      where+        l = numberedTreeRec n x+        fs = foldl' folder [l] xs+        folder is t = is ++ [numberedTreeRec m t]+          where+            m = fst $ last is++-------------------------------------------------------+------------------- APPLICATIVE STUFF -----------------+-------------------------------------------------------++instance MultiApplicative [] where+  liftA2Left _ [] _ = []+  liftA2Left _ _ [] = []+  liftA2Left f as bs = map (\i -> f (as !! i) (bs !! floor @Double ((fromIntegral i / fromIntegral n) * fromIntegral m))) [0 .. n - 1]+    where+      n = length as+      m = length bs+  liftA2Right f as bs = liftA2Left (flip f) bs as++instance Applicative Tree where+  pure = Leaf+  liftA2 f (Leaf x) (Leaf y) = Leaf $ f x y+  liftA2 f l@(Leaf _) (Branch ys) = Branch $ map (liftA2 f l) ys+  liftA2 f (Branch xs) l@(Leaf _) = Branch $ map (\x -> liftA2 f x l) xs+  liftA2 f (Branch xs) (Branch ys) = Branch $ lift2Both (liftA2 f) xs ys++instance MultiApplicative Tree where+  liftA2Left f (Leaf x) (Leaf y) = Leaf $ f x y+  liftA2Left f l@(Leaf _) (Branch ys) = Branch $ map (liftA2Left f l) ys+  liftA2Left f (Branch xs) l@(Leaf _) = Branch $ map (\x -> liftA2Left f x l) xs+  liftA2Left f (Branch xs) (Branch ys) = Branch $ liftA2Left (liftA2Left f) xs ys+  liftA2Right f (Leaf x) (Leaf y) = Leaf $ f x y+  liftA2Right f l@(Leaf _) (Branch ys) = Branch $ map (liftA2Right f l) ys+  liftA2Right f (Branch xs) l@(Leaf _) = Branch $ map (\x -> liftA2Right f x l) xs+  liftA2Right f (Branch xs) (Branch ys) = Branch $ liftA2Right (liftA2Right f) xs ys++lift2Both :: (a -> b -> c) -> [a] -> [b] -> [c]+lift2Both f as bs =+  if n < m+    then liftA2Right f as bs+    else liftA2Left f as bs+  where+    n = length as+    m = length bs++--------------------------------------------------+------------------- MONAD STUFF ------------------+--------------------------------------------------++instance MultiMonad [] where+  innerJoin = Prelude.concat+  outerJoin = Prelude.concat+  squeezeJoin = Prelude.concat++instance Monad Tree where+  (>>=) x f = innerJoin $ f <$> x++instance MultiMonad Tree where+  innerJoin t = squeezeJoin $ mapWithPos reduceNested t+  outerJoin = innerJoin+  squeezeJoin (Leaf x) = x+  squeezeJoin (Branch xs) = Branch $ map squeezeJoin xs++reduce :: (Int, Int) -> Tree a -> [Tree a]+reduce _ (Leaf x) = [Leaf x]+reduce (i, n) (Branch xs) =+  if count <= 0+    then []+    else take count $ drop (start `mod` m) (cycle xs)+  where+    m = length xs+    start = floor (fromIntegral (m * i) / fromIntegral n)+    end = ceiling (fromIntegral (m * (i + 1)) / fromIntegral n)+    count = end - start++reduceNested :: [(Int, Int)] -> Tree a -> Tree a+reduceNested [] x = x+reduceNested (i : is) x = Branch $ map (reduceNested is) (reduce i x)++mapWithPos :: ([(Int, Int)] -> a -> b) -> Tree a -> Tree b+mapWithPos f = go []+  where+    go path (Leaf x) = Leaf (f (reverse path) x)+    go path (Branch ts) = Branch [go ((i, length ts) : path) t | (i, t) <- zip [0 ..] ts]
+ src/zwirn-core/Zwirn/Core/Types.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Zwirn.Core.Types where++{-+    Types.hs - defines all core types and classes+    Copyright (C) 2025, 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.Monad (join)+import Control.Monad.Identity+import Zwirn.Core.Time++data Value i a+  = Value {value :: a, time :: !Time, info :: [i]}+  deriving (Eq, Show, Ord, Functor)++newtype ZwirnT k st i a = ZwirnT {unZwirnT :: Time -> st -> k (Value i a, st)}++unzwirn :: ZwirnT k st i a -> Time -> st -> k (Value i a, st)+unzwirn = unZwirnT++zwirn :: (Time -> st -> k (Value i a, st)) -> ZwirnT k st i a+zwirn = ZwirnT++-- | represents instances of k that allow for a special zwirn with no values+class HasSilence k where+  silence :: ZwirnT k st i a++class State k st i where+  beatsPerCycle :: ZwirnT k st i Double++class ToList k where+  toList :: k a -> [a]++infixl 4 *>++infixl 4 <*++class (Applicative f) => MultiApplicative f where+  liftA2Left :: (a -> b -> c) -> f a -> f b -> f c+  liftA2Right :: (a -> b -> c) -> f a -> f b -> f c+  liftA2Both :: (a -> b -> c) -> f a -> f b -> f c+  liftA2Both = liftA2+  (*>) :: f (a -> b) -> f a -> f b+  (*>) = liftA2Right id+  (<*) :: f (a -> b) -> f a -> f b+  (<*) = liftA2Left id++class (MultiApplicative m, Monad m) => MultiMonad m where+  innerJoin :: m (m a) -> m a+  innerJoin = join+  outerJoin :: m (m a) -> m a+  squeezeJoin :: m (m a) -> m a++instance ToList [] where+  toList = id++instance ToList Identity where+  toList (Identity x) = pure x++instance MultiApplicative Identity where+  liftA2Left f x y = Identity $ f (runIdentity x) (runIdentity y)+  liftA2Right f x y = Identity $ f (runIdentity x) (runIdentity y)++instance MultiMonad Identity where+  innerJoin (Identity x) = x+  outerJoin (Identity x) = x+  squeezeJoin (Identity x) = x++instance Applicative (Value i) where+  pure x = Value x 0 []+  liftA2 f (Value x t1 i1) (Value y _ i2) = Value (f x y) t1 (i1 ++ i2)++instance MultiApplicative (Value i) where+  liftA2Left = liftA2+  liftA2Right f (Value x _ i1) (Value y t2 i2) = Value (f x y) t2 (i1 ++ i2)
+ src/zwirn-lang/Zwirn/Language.hs view
@@ -0,0 +1,44 @@+module Zwirn.Language+  ( module Zwirn.Language.Block,+    module Zwirn.Language.Compiler,+    module Zwirn.Language.Lexer,+    module Zwirn.Language.Parser,+    module Zwirn.Language.Pretty,+    module Zwirn.Language.Simple,+    module Zwirn.Language.Syntax,+    module Zwirn.Language.TypeCheck.Constraint,+    module Zwirn.Language.Environment,+    module Zwirn.Language.TypeCheck.Infer,+    module Zwirn.Language.TypeCheck.Types,+  )+where++import Zwirn.Language.Block+import Zwirn.Language.Compiler+import Zwirn.Language.Environment+import Zwirn.Language.Lexer+import Zwirn.Language.Parser+import Zwirn.Language.Pretty+import Zwirn.Language.Simple+import Zwirn.Language.Syntax+import Zwirn.Language.TypeCheck.Constraint+import Zwirn.Language.TypeCheck.Infer+import Zwirn.Language.TypeCheck.Types++{-+    Language.hs - re-exports of all zwirn language modules+    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/>.+-}
+ src/zwirn-lang/Zwirn/Language/Block.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}++module Zwirn.Language.Block+  ( Block (..),+    BlockError,+    Line (..),+    getBlock,+    structureLines,+    getBlockContent,+    getLineIndent,+    getSingleLine,+    getBlockStart,+    getBlockEnd,+  )+where++{-+    Block.hs - layout sensitive representation of blocks of code+    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 qualified Data.List.NonEmpty as NE+import qualified Data.Text as T++-- | A Block of code is a non-empty list of lines of code+newtype Block = Block+  { bContent :: NE.NonEmpty Line+  }+  deriving (Show, Eq)++-- | A Line of code has a start line and an end line, if start /= end, it represents a multiline+data Line = Line+  { lStart :: Int,+    lEnd :: Int,+    lContent :: T.Text+  }+  deriving (Show, Eq)++type BlockError = String++-- | Get the start line of a block, assumes that the lines are ordered.+getBlockStart :: Block -> Int+getBlockStart (Block ls) = lStart $ NE.head ls++-- | Get the end line of a block, assumes that the lines are ordered.+getBlockEnd :: Block -> Int+getBlockEnd (Block ls) = lEnd $ NE.last ls++-- | Get the contents of a block by merging the contents of its lines+getBlockContent :: Block -> [T.Text]+getBlockContent (Block ls) = NE.toList $ NE.map lContent ls++-- | Given a line number and a list of blocks, get the block that starts before and ends after the line.+getBlock :: Int -> [Block] -> Either BlockError Block+getBlock _ [] = Left "no block of code at current line"+getBlock num (block : bs) =+  if start <= num && num <= end+    then Right block+    else getBlock num bs+  where+    start = getBlockStart block+    end = getBlockEnd block++-- | Given a line number and a non-empty list of lines, get the line that starts before and ends after the line number.+getLine' :: Int -> NE.NonEmpty Line -> Either BlockError Line+getLine' num (l@(Line st en _) NE.:| ls) =+  if st <= num && num <= en+    then Right l+    else case NE.nonEmpty ls of+      Just xs -> getLine' num xs+      Nothing -> Left "no line at current position"++getSingleLine :: Int -> [Block] -> Either BlockError Line+getSingleLine i bs = do+  (Block ls) <- getBlock i bs+  getLine' i ls++-- | Parsing Blocks of code is layout sensitive - this function merges lines of code into a single multiline+-- | whenever the indent of the first line is smaller than the indent of the following lines+structureLines :: NE.NonEmpty Line -> NE.NonEmpty Line+structureLines (l NE.:| ls) = mergeLines vs NE.:| rs+  where+    vs = l NE.:| takeWhile (\x -> getLineIndent x > getLineIndent l) ls+    rs = case NE.nonEmpty $ drop (length vs - 1) ls of+      Just xs -> NE.toList $ structureLines xs+      Nothing -> []++-- | checks how many spaces or tabs are at the start of the line content+getLineIndent :: Line -> Int+getLineIndent (Line _ _ lc) = T.length $ T.takeWhile (\c -> c `elem` (" \t" :: String)) lc++-- | combines lines to a single multiline by merging their content and adjusting the end line+mergeLines :: NE.NonEmpty Line -> Line+mergeLines ((Line lst len c) NE.:| ls) = Line lst end (T.concat $ c : map lContent ls)+  where+    end = if null ls then len else lEnd $ last ls
+ src/zwirn-lang/Zwirn/Language/Builtin/Internal.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Language.Builtin.Internal where++import qualified Data.Map as Map+import Data.String+import Data.Text (Text, pack)+import Zwirn.Language.Environment+import Zwirn.Language.Evaluate hiding (insert)+import Zwirn.Language.Parser (parseScheme)+import Zwirn.Language.TypeCheck.Types++instance IsString Scheme where+  fromString s = fromEither $ parseScheme (pack s)+    where+      fromEither (Right r) = r+      fromEither (Left e) = error e++(===) :: Text -> Expression -> Map.Map Text Expression+(===) = Map.singleton++(<::) :: Map.Map Text Expression -> Scheme -> Map.Map Text (Expression, Scheme)+(<::) x s = fmap (\l -> (l, s)) x++(--|) :: Map.Map Text (Expression, Scheme) -> Text -> Map.Map Text AnnotatedExpression+(--|) n t = fmap (\(x, s) -> Annotated x s (Just t)) n++noDesc :: Map.Map Text (Expression, Scheme) -> Map.Map Text AnnotatedExpression+noDesc = fmap (\(x, s) -> Annotated x s Nothing)
+ src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE OverloadedStrings #-}++module Zwirn.Language.Builtin.Parameters where++import qualified Data.Map as Map+import Data.Text (Text, append, uncons)+import Zwirn.Core.Cord (stack)+import Zwirn.Core.Lib.Cord (applyCord)+import Zwirn.Core.Lib.Map+import Zwirn.Language.Builtin.Internal+import Zwirn.Language.Environment+import Zwirn.Language.Evaluate (Expression, Zwirn, toExp)++builtinParams :: Map.Map Text AnnotatedExpression+builtinParams = addAliases aliases $ Map.unions [builtinTextParams, builtinNumberParams, builtinIntParams]++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++builtinNumberParams :: Map.Map Text AnnotatedExpression+builtinNumberParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Double -> Zwirn Expression) <:: "Number -> Map") numberParams++builtinIntParams :: Map.Map Text AnnotatedExpression+builtinIntParams = Map.unions $ map (\t -> noDesc $ t === toExp ((fmap toExp . singleton (pure t)) :: Zwirn Int -> Zwirn Expression) <:: "Number -> Map") intParams++textParams :: [Text]+textParams = ["s", "unit", "vowel", "toArg"]++intParams :: [Text]+intParams = ["cut", "orbit"]++numberParams :: [Text]+numberParams =+  [ "accelerate",+    "amp",+    "attack",+    "bandf",+    "bandq",+    "begin",+    "binshift",+    "ccn",+    "ccv",+    "channel",+    "coarse",+    "comb",+    "crush",+    "cutoff",+    "decay",+    "delay",+    "delaytime",+    "detune",+    "distort",+    "djf",+    "dry",+    "dur",+    "end",+    "enhance",+    "expression",+    "fadeInTime",+    "fadeTime",+    "freeze",+    "freq",+    "from",+    "fshift",+    "gain",+    "gate",+    "harmonic",+    "hbrick",+    "hcutoff",+    "hold",+    "hresonance",+    "imag",+    "krush",+    "lagogo",+    "lbrick",+    "legato",+    "leslie",+    "lock",+    "midibend",+    "miditouch",+    "modwheel",+    "n",+    "note",+    "nudge",+    "octave",+    "octer",+    "octersub",+    "octersubsub",+    "offset",+    "overgain",+    "overshape",+    "pan",+    "panorient",+    "panspan",+    "pansplay",+    "panwidth",+    "partials",+    "phaserdepth",+    "phaserrate",+    "rate",+    "real",+    "release",+    "resonance",+    "ring",+    "ringdf",+    "ringf",+    "room",+    "sagogo",+    "scram",+    "shape",+    "size",+    "slide",+    "smear",+    "speed",+    "squiz",+    "sustain",+    "sustainpedal",+    "timescale",+    "timescalewin",+    "to",+    "tremolodepth",+    "tremolorate",+    "triode",+    "tsdelay",+    "velocity",+    "voice",+    "waveloss",+    "xsdelay"+  ]++aliases :: [(Text, Text)]+aliases =+  [ ("sound", "s"),+    ("voi", "voice"),+    ("up", "n"),+    ("tremr", "tremolorate"),+    ("tremdp", "tremolodepth"),+    ("sz", "size"),+    ("sus", "sustain"),+    ("sld", "slide"),+    ("scr", "scrash"),+    ("rel", "release"),+    ("por", "portamento"),+    ("phasr", "phaserrate"),+    ("phasdp", "phaserdepth"),+    ("number", "n"),+    ("lpq", "resonance"),+    ("lpf", "cutoff"),+    ("hpq", "hresonance"),+    ("hpf", "hcutoff"),+    ("gat", "gate"),+    ("fadeOutTime", "fadeTime"),+    ("dt", "delaytime"),+    ("dfb", "delayfeedback"),+    ("det", "detune"),+    ("delayt", "delaytime"),+    ("delayfb", "delayfeedback"),+    ("ctf", "cutoff"),+    ("bpq", "bandq"),+    ("bpf", "bandf"),+    ("att", "attack")+  ]++addAliases :: [(Text, Text)] -> Map.Map Text AnnotatedExpression -> Map.Map Text AnnotatedExpression+addAliases as x = Map.unions $ map look as ++ [x]+  where+    look (y, n) = case Map.lookup n x of+      Just a -> Map.singleton y a+      Nothing -> Map.empty++----------------------------------------------------------+---------------- defining note names ---------------------+----------------------------------------------------------++noteExpressions :: Map.Map Text AnnotatedExpression+noteExpressions = Map.unions $ map (\n -> noDesc $ n === toExp ((pure $ toNote n) :: Zwirn Int) <:: "Number") notes++chordExpressions :: Map.Map Text AnnotatedExpression+chordExpressions = Map.unions $ map (\(n, cs) -> noDesc $ n === toExp ((\z -> applyCord z (stack $ map pure cs)) :: Zwirn Int -> Zwirn Int) <:: "Number -> Number") chordTable++noteNames :: [Text]+noteNames = ["c", "d", "e", "f", "g", "a", "b"]++noteMods :: [Text]+noteMods = ["", "f", "s"]++noteOctaves :: [Text]+noteOctaves = ["", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"]++notes :: [Text]+notes = [n `append` m `append` o | n <- noteNames, m <- noteMods, o <- noteOctaves]++modVal :: Char -> Int+modVal 'f' = -1+modVal 's' = 1+modVal _ = 0++nameVal :: Char -> Int+nameVal 'c' = 0+nameVal 'd' = 2+nameVal 'e' = 4+nameVal 'f' = 5+nameVal 'g' = 7+nameVal 'a' = 9+nameVal 'b' = 11+nameVal _ = 0++octVal :: Char -> Int+octVal '0' = -60+octVal '1' = -48+octVal '2' = -36+octVal '3' = -24+octVal '4' = -12+octVal '5' = 0+octVal '6' = 12+octVal '7' = 24+octVal '8' = 36+octVal '9' = 48+octVal _ = 0++toNote :: Text -> Int+toNote t = case uncons t of+  Just (x, xs) -> case uncons xs of+    Just (y, ys) -> case uncons ys of+      Just (z, _) -> nameVal x + modVal y + octVal z+      Nothing -> nameVal x + modVal y + octVal y+    Nothing -> nameVal x+  Nothing -> 0++-- the following is taken from https://hackage.haskell.org/package/tidal-1.9.5/docs/src/Sound.Tidal.Chords.html+chordTable :: (Num a) => [(Text, [a])]+chordTable =+  [ ("major", major),+    ("maj", major),+    ("M", major),+    ("aug", aug),+    ("plus", aug),+    ("sharp5", aug),+    ("six", six),+    ("sixNine", sixNine),+    ("six9", sixNine),+    ("sixby9", sixNine),+    ("6by9", sixNine),+    ("major7", major7),+    ("maj7", major7),+    ("major9", major9),+    ("maj9", major9),+    ("add9", add9),+    ("major11", major11),+    ("maj11", major11),+    ("add11", add11),+    ("major13", major13),+    ("maj13", major13),+    ("add13", add13),+    ("dom7", dom7),+    ("dom9", dom9),+    ("dom11", dom11),+    ("dom13", dom13),+    ("sevenFlat5", sevenFlat5),+    ("7f5", sevenFlat5),+    ("sevenSharp5", sevenSharp5),+    ("7s5", sevenSharp5),+    ("sevenFlat9", sevenFlat9),+    ("7f9", sevenFlat9),+    ("nine", nine),+    ("eleven", eleven),+    ("thirteen", thirteen),+    ("minor", minor),+    ("min", minor),+    ("m", minor),+    ("diminished", diminished),+    ("dim", diminished),+    ("minorSharp5", minorSharp5),+    ("msharp5", minorSharp5),+    ("mS5", minorSharp5),+    ("minor6", minor6),+    ("min6", minor6),+    ("m6", minor6),+    ("minorSixNine", minorSixNine),+    ("minor69", minorSixNine),+    ("min69", minorSixNine),+    ("minSixNine", minorSixNine),+    ("m69", minorSixNine),+    ("mSixNine", minorSixNine),+    ("m6by9", minorSixNine),+    ("minor7flat5", minor7flat5),+    ("minor7f5", minor7flat5),+    ("min7flat5", minor7flat5),+    ("min7f5", minor7flat5),+    ("m7flat5", minor7flat5),+    ("m7f5", minor7flat5),+    ("minor7", minor7),+    ("min7", minor7),+    ("m7", minor7),+    ("minor7sharp5", minor7sharp5),+    ("minor7s5", minor7sharp5),+    ("min7sharp5", minor7sharp5),+    ("min7s5", minor7sharp5),+    ("m7sharp5", minor7sharp5),+    ("m7s5", minor7sharp5),+    ("minor7flat9", minor7flat9),+    ("minor7f9", minor7flat9),+    ("min7flat9", minor7flat9),+    ("min7f9", minor7flat9),+    ("m7flat9", minor7flat9),+    ("m7f9", minor7flat9),+    ("minor7sharp9", minor7sharp9),+    ("minor7s9", minor7sharp9),+    ("min7sharp9", minor7sharp9),+    ("min7s9", minor7sharp9),+    ("m7sharp9", minor7sharp9),+    ("m7s9", minor7sharp9),+    ("diminished7", diminished7),+    ("dim7", diminished7),+    ("minor9", minor9),+    ("min9", minor9),+    ("m9", minor9),+    ("minor11", minor11),+    ("min11", minor11),+    ("m11", minor11),+    ("minor13", minor13),+    ("min13", minor13),+    ("m13", minor13),+    ("minorMajor7", minorMajor7),+    ("minMaj7", minorMajor7),+    ("mmaj7", minorMajor7),+    ("one", one),+    ("five", five),+    ("sus2", sus2),+    ("sus4", sus4),+    ("sevenSus2", sevenSus2),+    ("7sus2", sevenSus2),+    ("sevenSus4", sevenSus4),+    ("7sus4", sevenSus4),+    ("nineSus4", nineSus4),+    ("ninesus4", nineSus4),+    ("9sus4", nineSus4),+    ("sevenFlat10", sevenFlat10),+    ("7f10", sevenFlat10),+    ("nineSharp5", nineSharp5),+    ("9sharp5", nineSharp5),+    ("9s5", nineSharp5),+    ("minor9sharp5", minor9sharp5),+    ("minor9s5", minor9sharp5),+    ("min9sharp5", minor9sharp5),+    ("min9s5", minor9sharp5),+    ("m9sharp5", minor9sharp5),+    ("m9s5", minor9sharp5),+    ("sevenSharp5flat9", sevenSharp5flat9),+    ("7s5f9", sevenSharp5flat9),+    ("minor7sharp5flat9", minor7sharp5flat9),+    ("m7sharp5flat9", minor7sharp5flat9),+    ("elevenSharp", elevenSharp),+    ("minor11sharp", minor11sharp),+    ("m11sharp", minor11sharp),+    ("m11s", minor11sharp)+  ]+  where+    major :: (Num a) => [a]+    major = [0, 4, 7]+    aug :: (Num a) => [a]+    aug = [0, 4, 8]+    six :: (Num a) => [a]+    six = [0, 4, 7, 9]+    sixNine :: (Num a) => [a]+    sixNine = [0, 4, 7, 9, 14]+    major7 :: (Num a) => [a]+    major7 = [0, 4, 7, 11]+    major9 :: (Num a) => [a]+    major9 = [0, 4, 7, 11, 14]+    add9 :: (Num a) => [a]+    add9 = [0, 4, 7, 14]+    major11 :: (Num a) => [a]+    major11 = [0, 4, 7, 11, 14, 17]+    add11 :: (Num a) => [a]+    add11 = [0, 4, 7, 17]+    major13 :: (Num a) => [a]+    major13 = [0, 4, 7, 11, 14, 21]+    add13 :: (Num a) => [a]+    add13 = [0, 4, 7, 21]++    -- \** Dominant chords++    dom7 :: (Num a) => [a]+    dom7 = [0, 4, 7, 10]+    dom9 :: (Num a) => [a]+    dom9 = [0, 4, 7, 14]+    dom11 :: (Num a) => [a]+    dom11 = [0, 4, 7, 17]+    dom13 :: (Num a) => [a]+    dom13 = [0, 4, 7, 21]+    sevenFlat5 :: (Num a) => [a]+    sevenFlat5 = [0, 4, 6, 10]+    sevenSharp5 :: (Num a) => [a]+    sevenSharp5 = [0, 4, 8, 10]+    sevenFlat9 :: (Num a) => [a]+    sevenFlat9 = [0, 4, 7, 10, 13]+    nine :: (Num a) => [a]+    nine = [0, 4, 7, 10, 14]+    eleven :: (Num a) => [a]+    eleven = [0, 4, 7, 10, 14, 17]+    thirteen :: (Num a) => [a]+    thirteen = [0, 4, 7, 10, 14, 17, 21]++    -- \** Minor chords++    minor :: (Num a) => [a]+    minor = [0, 3, 7]+    diminished :: (Num a) => [a]+    diminished = [0, 3, 6]+    minorSharp5 :: (Num a) => [a]+    minorSharp5 = [0, 3, 8]+    minor6 :: (Num a) => [a]+    minor6 = [0, 3, 7, 9]+    minorSixNine :: (Num a) => [a]+    minorSixNine = [0, 3, 9, 7, 14]+    minor7flat5 :: (Num a) => [a]+    minor7flat5 = [0, 3, 6, 10]+    minor7 :: (Num a) => [a]+    minor7 = [0, 3, 7, 10]+    minor7sharp5 :: (Num a) => [a]+    minor7sharp5 = [0, 3, 8, 10]+    minor7flat9 :: (Num a) => [a]+    minor7flat9 = [0, 3, 7, 10, 13]+    minor7sharp9 :: (Num a) => [a]+    minor7sharp9 = [0, 3, 7, 10, 15]+    diminished7 :: (Num a) => [a]+    diminished7 = [0, 3, 6, 9]+    minor9 :: (Num a) => [a]+    minor9 = [0, 3, 7, 10, 14]+    minor11 :: (Num a) => [a]+    minor11 = [0, 3, 7, 10, 14, 17]+    minor13 :: (Num a) => [a]+    minor13 = [0, 3, 7, 10, 14, 17, 21]+    minorMajor7 :: (Num a) => [a]+    minorMajor7 = [0, 3, 7, 11]++    -- \** Other chords++    one :: (Num a) => [a]+    one = [0]+    five :: (Num a) => [a]+    five = [0, 7]+    sus2 :: (Num a) => [a]+    sus2 = [0, 2, 7]+    sus4 :: (Num a) => [a]+    sus4 = [0, 5, 7]+    sevenSus2 :: (Num a) => [a]+    sevenSus2 = [0, 2, 7, 10]+    sevenSus4 :: (Num a) => [a]+    sevenSus4 = [0, 5, 7, 10]+    nineSus4 :: (Num a) => [a]+    nineSus4 = [0, 5, 7, 10, 14]++    -- \** Questionable chords++    sevenFlat10 :: (Num a) => [a]+    sevenFlat10 = [0, 4, 7, 10, 15]+    nineSharp5 :: (Num a) => [a]+    nineSharp5 = [0, 1, 13]+    minor9sharp5 :: (Num a) => [a]+    minor9sharp5 = [0, 1, 14]+    sevenSharp5flat9 :: (Num a) => [a]+    sevenSharp5flat9 = [0, 4, 8, 10, 13]+    minor7sharp5flat9 :: (Num a) => [a]+    minor7sharp5flat9 = [0, 3, 8, 10, 13]+    elevenSharp :: (Num a) => [a]+    elevenSharp = [0, 4, 7, 10, 14, 18]+    minor11sharp :: (Num a) => [a]+    minor11sharp = [0, 3, 7, 10, 14, 18]
+ src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs view
@@ -0,0 +1,1032 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Language.Builtin.Prelude where++{-+    Builtin.hs - defines builtin functions+    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 qualified Data.Map as Map+import Data.Text (Text)+import Zwirn.Core.Lib.Conditional as Z+import Zwirn.Core.Lib.Cord as C+import Zwirn.Core.Lib.Core as C+import Zwirn.Core.Lib.Map as M+import Zwirn.Core.Lib.Modulate+import Zwirn.Core.Lib.Number as N+import Zwirn.Core.Lib.Random+import Zwirn.Core.Lib.Structure as S+import Zwirn.Core.Time+import Zwirn.Language.Builtin.Internal+import Zwirn.Language.Builtin.Parameters+import Zwirn.Language.Environment+import Zwirn.Language.Evaluate hiding (insert)+import Zwirn.Language.TypeCheck.Types+import Zwirn.Stream.Types (Stream)++builtinEnvironment :: InterpreterEnv+builtinEnvironment = IEnv builtins instances++builtinEnvironmentWithStream :: Stream -> InterpreterEnv+builtinEnvironmentWithStream str = IEnv (Map.unions [builtins, streamFunctions str]) instances++instances :: [Instance]+instances =+  [ IsIn "Num" numberT,+    IsIn "Num" mapT,+    IsIn "Eq" numberT,+    IsIn "Eq" mapT,+    IsIn "Eq" textT,+    IsIn "Id" numberT,+    IsIn "Id" textT,+    IsIn "Id" mapT+  ]++builtinNames :: [Text]+builtinNames = Map.keys builtins++builtins :: Map.Map Text AnnotatedExpression+builtins =+  Map.unions+    [ coreFunctions,+      numberFunctions,+      signals,+      randomFunctions,+      timeFunctions,+      structureFunctions,+      conditionalFunctions,+      cordFunctions,+      mapFunctions,+      builtinParams,+      noteExpressions,+      chordExpressions+    ]++coreFunctions :: Map.Map Text AnnotatedExpression+coreFunctions =+  Map.unions+    [ "id"+        === lambda id+        <:: "a -> a"+        --| "identity function",+      "const"+        === lambda (lambda . const)+        <:: "a -> b -> a"+        --| "constant function - ignore second input",+      "scomb"+        === lambda (\f -> lambda $ \g -> lambda $ \x -> f ! x ! (g ! x))+        <:: "(a -> b -> c) -> (a -> b) -> a -> c"+        --| "S-combinator",+      "(.)"+        === lambda (\g -> lambda $ \f -> lambda $ \x -> g ! (f ! x))+        <:: "(b -> c) -> (a -> b) -> a -> c"+        --| "function composition",+      "flip"+        === lambda (\f -> lambda $ \y -> lambda $ \x -> f ! x ! y)+        <:: "(a -> b -> c) -> b -> a -> c"+        --| "flip arguments",+      "(\')"+        === toExp (flip apply :: Zwirn Expression -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression)+        <:: "a -> (a -> b) -> b"+        --| "apply argument to function, results are squeezed and zipped",+      "($)"+        === toExp (apply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply function to argument, results are squeezed and zipped",+      "match"+        === toExp (matchApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "",+      "iterate"+        === toExp (C.iterate :: Zwirn Int -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> a) -> a -> a"+        --| "apply function to argument, n times",+      "(|$)"+        === toExp (outerApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply function to argument",+      "($|)"+        === toExp (innerApply :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply function to argument",+      "squeeze"+        === toExp (squeeze :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "map a function over the structure of the argument",+      "inner"+        === toExp (getInnerTime :: Zwirn Expression -> Zwirn Double)+        <:: "a -> Number"+        --| "get the inner time of a zwirn",+      "diff"+        === toExp (getSpeed :: Zwirn Expression -> Zwirn Double)+        <:: "a -> Number"+        --| "get the speed of a zwirn",+      "trig"+        === toExp (trig :: Zwirn Expression -> Zwirn Bool)+        <:: "a -> Number"+        --| "returns true on the trigger points, false otherwise",+      "recv"+        === toExp recv+        <:: "(Number -> Map) -> Number -> Map"+        --| "recieve a value from a bus and send it to the given parameter",+      "recvT"+        === toExp recvT+        <:: "Text -> Number -> Map"+        --| "like recv but takes the parameter name as text"+    ]++numberFunctions :: Map.Map Text AnnotatedExpression+numberFunctions =+  Map.unions+    [ "(|+)"+        === toExp ((+) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a -> a"+        --| "addition",+      "(|-)"+        === toExp ((-) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a -> a"+        --| "subtraction",+      "(|*)"+        === toExp ((*) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a -> a"+        --| "multiplication",+      "(|/)"+        === toExp ((/) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a -> a"+        --| "division",+      "negate"+        === toExp (negate :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "negate",+      "abs"+        === toExp (abs :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "absolute value",+      "signum"+        === toExp (signum :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a =>  a -> a"+        --| "signum",+      "recip"+        === toExp (recip :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "reciprocal value",+      "pi"+        === toExp (pi :: Zwirn Expression)+        <:: "Number"+        --| "pi",+      "(|**)"+        === toExp ((**) :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a -> a"+        --| "exponentiation",+      "exp"+        === toExp (exp :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "exponential function",+      "log"+        === toExp (log :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "logarithm base 10",+      "sqrt"+        === toExp (sqrt :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a =>  a -> a"+        --| "square root",+      "sin"+        === toExp (sin :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "sine function",+      "cos"+        === toExp (cos :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "cosine function",+      "tan"+        === toExp (tan :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "tangens",+      "asin"+        === toExp (asin :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "arc sine function",+      "acos"+        === toExp (acos :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "arc cosine function",+      "atan"+        === toExp (atan :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "arc tangens",+      "sinh"+        === toExp (sinh :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "hyperbolic sine",+      "cosh"+        === toExp (cosh :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a =>  a -> a"+        --| "hyperbolic cosine",+      "tanh"+        === toExp (tan :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "hyperbolic tangens",+      "asinh"+        === toExp (asinh :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "hyperbolic arc sine function",+      "acosh"+        === toExp (acosh :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "hyperbolic arc cosine function",+      "atanh"+        === toExp (atanh :: Zwirn Expression -> Zwirn Expression)+        <:: "Num a => a -> a"+        --| "hyperbolic arc tangens",+      "mod"+        === toExp (N.mod :: Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number"+        --| "modulo",+      "frac"+        === toExp (N.frac :: Zwirn Double -> Zwirn Double)+        <:: "Number -> Number"+        --| "fractional part of a number",+      "trunc"+        === toExp (N.trunc :: Zwirn Double -> Zwirn Int)+        <:: "Number -> Number"+        --| "truncate",+      "ceil"+        === toExp (N.ceil :: Zwirn Double -> Zwirn Int)+        <:: "Number -> Number"+        --| "round up",+      "floor"+        === toExp (N.floor :: Zwirn Double -> Zwirn Int)+        <:: "Number -> Number"+        --| "round down",+      "round"+        === toExp (N.round :: Zwirn Double -> Zwirn Int)+        <:: "Number -> Number"+        --| "round to closest",+      "gcd"+        === toExp (N.gcd :: Zwirn Int -> Zwirn Int -> Zwirn Int)+        <:: "Number -> Number -> Number"+        --| "greatest common divisor",+      "lcm"+        === toExp (N.lcm :: Zwirn Int -> Zwirn Int -> Zwirn Int)+        <:: "Number -> Number -> Number"+        --| "least common multiple",+      "range"+        === toExp (range :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number -> Number"+        --| "range x y l maps number l linearly into interval (x,y), assuming l is between 0 and 1"+    ]++signals :: Map.Map Text AnnotatedExpression+signals =+  Map.unions+    [ "now"+        === toExp (now :: Zwirn Time)+        <:: "Number"+        --| "current time",+      "cyc"+        === toExp (C.cyc :: Zwirn Int)+        <:: "Number"+        --| "current cycle",+      "sine"+        === toExp (sine :: Zwirn Time)+        <:: "Number"+        --| "sine signal",+      "sine2"+        === toExp (sine2 :: Zwirn Time)+        <:: "Number"+        --| "bipolar sine signal",+      "saw"+        === toExp (saw :: Zwirn Time)+        <:: "Number"+        --| "saw signal",+      "saw2"+        === toExp (saw2 :: Zwirn Time)+        <:: "Number"+        --| "bipolar saw signal",+      "cosine"+        === toExp (cosine :: Zwirn Time)+        <:: "Number"+        --| "cosine signal",+      "cosine2"+        === toExp (cosine2 :: Zwirn Time)+        <:: "Number"+        --| "bipolar cosine signal",+      "isaw"+        === toExp (isaw :: Zwirn Time)+        <:: "Number"+        --| "inverse saw signal",+      "isaw2"+        === toExp (isaw2 :: Zwirn Time)+        <:: "Number"+        --| "bipolar inverse saw signal",+      "tri"+        === toExp (tri :: Zwirn Time)+        <:: "Number"+        --| "triangle signal",+      "tri2"+        === toExp (tri2 :: Zwirn Time)+        <:: "Number"+        --| "bipolar triangle signal",+      "square"+        === toExp (square :: Zwirn Time)+        <:: "Number"+        --| "square signal",+      "square2"+        === toExp (square2 :: Zwirn Time)+        <:: "Number"+        --| "bipolar square signal",+      "firstCyclesThen"+        === toExp (firstCyclesThen :: Zwirn Time -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a -> a"+        --| "bipolar square signal"+    ]++randomFunctions :: Map.Map Text AnnotatedExpression+randomFunctions =+  Map.unions+    [ "rand"+        === toExp (noise :: Zwirn Double)+        <:: "Number"+        --| "random stream of values between 0 and 1",+      "brand"+        === toExp (rand :: Zwirn Bool)+        <:: "Number"+        --| "random binary choice",+      "brandBy"+        === toExp (brandBy :: Zwirn Double -> Zwirn Bool)+        <:: "Number -> Number"+        --| "weighted random binary choice",+      "irand"+        === toExp (irand :: Zwirn Int -> Zwirn Int)+        <:: "Number -> Number"+        --| "random integer values between 0 and given input",+      "cycrand"+        === toExp (rand' :: Zwirn Double)+        <:: "Number"+        --| "random stream of values between 0 and 1, one value per cycle",+      "cycbrand"+        === toExp (rand :: Zwirn Bool)+        <:: "Number"+        --| "random binary cyclewise choice",+      "cycbrandBy"+        === toExp (brandBy' :: Zwirn Double -> Zwirn Bool)+        <:: "Number -> Number"+        --| "weighted random binary cyclewise choice",+      "cycirand"+        === toExp (irand' :: Zwirn Int -> Zwirn Int)+        <:: "Number -> Number"+        --| "random integer values between 0 and given input, one value per cycle",+      "perlin"+        === toExp (perlin :: Zwirn Double)+        <:: "Number"+        --| "perlin noise between 0 and 1",+      "simplex"+        === toExp (simplex :: Zwirn Double)+        <:: "Number"+        --| "simplex noise between 0 and 1",+      "ssimplex"+        === toExp (ssimplex :: Zwirn Double)+        <:: "Number"+        --| "super simplex noise between 0 and 1",+      "value"+        === toExp (valueN :: Zwirn Double)+        <:: "Number"+        --| "value noise between 0 and 1",+      "cubic"+        === toExp (cubic :: Zwirn Double)+        <:: "Number"+        --| "cubic value noise between 0 and 1",+      "perlinS"+        === toExp (perlinSeed :: Zwirn Int -> Zwirn Double)+        <:: "Number -> Number"+        --| "seeded perlin noise between 0 and 1",+      "simplexS"+        === toExp (simplexSeed :: Zwirn Int -> Zwirn Double)+        <:: "Number -> Number"+        --| "seeded simplex noise between 0 and 1",+      "ssimplexS"+        === toExp (ssimplexSeed :: Zwirn Int -> Zwirn Double)+        <:: "Number -> Number"+        --| "seeded super simplex noise between 0 and 1",+      "valueS"+        === toExp (valueSeed :: Zwirn Int -> Zwirn Double)+        <:: "Number -> Number"+        --| "seeded value noise between 0 and 1",+      "cubicS"+        === toExp (cubicSeed :: Zwirn Int -> Zwirn Double)+        <:: "Number -> Number"+        --| "seeded cubic value noise between 0 and 1",+      "somecyclesBy"+        === toExp (somecyclesBy :: Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> b) -> a -> b"+        --| "apply a function with a given chance per cycle",+      "somecycles"+        === toExp (somecycles :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply a functions with a 50% chance per cycle",+      "sometimesBy"+        === toExp (sometimesBy :: Zwirn Double -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> b) -> a -> b"+        --| "apply a function with a given chance",+      "sometimes"+        === toExp (sometimes :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply a function with a 50% chance",+      "often"+        === toExp (often :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply a function with a 75% chance",+      "rarely"+        === toExp (rarely :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply a function with a 25% chance",+      "almostNever"+        === toExp (almostNever :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply a function with a 10% chance",+      "almostAlways"+        === toExp (almostNever :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "apply a function with a 90% chance",+      "chooseFromTo"+        === toExp (enumFromToChoice 0 :: Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number"+        --| "```chooseFromTo x y == [x | .. y]```",+      "chooseFromThenTo"+        === toExp (enumFromThenToChoice 0 :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number -> Number"+        --| "```chooseFromTo x y z == [x | y .. z]```"+    ]++timeFunctions :: Map.Map Text AnnotatedExpression+timeFunctions =+  Map.unions+    [ "(*)"+        === toExp (flip fast :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)+        <:: "a -> Number -> a"+        --| "multiply time, making it faster",+      "fast"+        === toExp (fast :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "multiply time, making it faster",+      "(/)"+        === toExp (flip slow :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)+        <:: "a -> Number -> a"+        --| "divide time, making it slower",+      "slow"+        === toExp (slow :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "divide time, making it slower",+      "(+)"+        === toExp (flip shift :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)+        <:: "a -> Number -> a"+        --| "shift time to the right",+      "(-)"+        === toExp (flip (shift . fmap negate) :: Zwirn Expression -> Zwirn Time -> Zwirn Expression)+        <:: "a -> Number -> a"+        --| "shift time to the left",+      "shift"+        === toExp (shift :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "shift time",+      "revBy"+        === toExp (revBy :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "reverse time, piecewise",+      "rev"+        === toExp (rev :: Zwirn Expression -> Zwirn Expression)+        <:: "a -> a"+        --| "reverse time completely",+      "ply"+        === toExp (ply :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "speed up time inside",+      "bump"+        === toExp (bump :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "shift time inside",+      "timeloop"+        === toExp (timeloop :: Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "loop time from 0 to the given number",+      "loop"+        === toExp (loop :: Zwirn Time -> Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> a -> a"+        --| "loop a specifc range of a zwirn, speeding up",+      "ribbon"+        === toExp (ribbon :: Zwirn Time -> Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> a -> a"+        --| "given an offset and a length, loops the according region",+      "zoom"+        === toExp (zoom :: Zwirn Time -> Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> a -> a"+        --| "zoom and loop a part of a zwirn",+      "swingBy"+        === toExp (swingBy :: Zwirn Time -> Zwirn Time -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> a -> a"+        --| "given a swing amount and a number of subdivisions, shifts the second half of every subdivion by the given amount, creating a swing feel."+    ]++structureFunctions :: Map.Map Text AnnotatedExpression+structureFunctions =+  Map.unions+    [ "euclidOff"+        === toExp (euclidOff :: Zwirn Int -> Zwirn Int -> Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> Number -> a -> a"+        --| "shifted euclidean rhythm",+      "euclid"+        === toExp (euclid :: Zwirn Int -> Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> a -> a"+        --| "euclidean rhythm",+      "euclideanOff"+        === toExp (euclidean :: Zwirn Int -> Zwirn Int -> Zwirn Int -> Zwirn String)+        <:: "Number -> Number -> Number -> Text"+        --| "string representation of shifted euclidean rhythm",+      "euclidean"+        === toExp ((euclidean $ pure 0) :: Zwirn Int -> Zwirn Int -> Zwirn String)+        <:: "Number -> Number -> Number -> Text"+        --| "string representation of euclidean rhythm",+      "binary"+        === toExp (binary :: Zwirn Int -> Zwirn String)+        <:: "Number -> Text"+        --| "converts number to binary sequence",+      "christoffel"+        === toExp (christoffel :: Zwirn Int -> Zwirn Int -> Zwirn String)+        <:: "Number -> Number -> Text"+        --| "create the two alphabet christoffel word",+      "neg"+        === toExp (neg :: Zwirn String -> Zwirn String)+        <:: "Text -> Text"+        --| "make onsets to offsets in chunk notation",+      -- "rotate"+      --   === toExp (rotate :: Zwirn Int -> Zwirn String -> Zwirn String)+      --   <:: "Number -> Text -> Text"+      --   --| "rotate characters in a string by amount",+      "chunkWith"+        === toExp (chunkWith :: Zwirn Double -> Zwirn String -> Zwirn Int)+        <:: "Number -> Text -> Number"+        --| "converts from Boenn's chunk notation to a rhythm",+      "chunk"+        === toExp (chunk :: Zwirn String -> Zwirn Int)+        <:: "Text -> Number"+        --| "converts from Boenn's chunk notation to a rhythm",+      "chunked"+        === toExp (chunked :: Zwirn String -> Zwirn Expression -> Zwirn Expression)+        <:: "Text -> a -> a"+        --| "converts from Boenn's chunk notation to a rhythm",+      "segment"+        === toExp (segment :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "divide structure into equal pieces",+      "sample"+        === toExp (sampleAndHold :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "like segment, but the values are held ('sample and hold')",+      "struct"+        === toExp (struct :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "a -> b -> b"+        --| "copy the structure from first value",+      "run"+        === toExp (run :: Zwirn Int -> Zwirn Int)+        <:: "Number -> Number"+        --| "```run n == [0 .. n-1]```",+      "runFromTo"+        === toExp (runFromTo :: Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number"+        --| "```runFromTo x y == [x .. y]```",+      "runFromThenTo"+        === toExp (runFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number -> Number"+        --| "```runFromTo x y z == [x y ..  z]```",+      "slowrun"+        === toExp (slowrun :: Zwirn Int -> Zwirn Int)+        <:: "Number -> Number"+        --| "```run n == <0 .. n-1>```",+      "slowrunFromTo"+        === toExp (slowrunFromTo :: Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number"+        --| "```slowrunFromTo x y == <x .. y>```",+      "slowrunFromThenTo"+        === toExp (slowrunFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number -> Number"+        --| "```slowrunFromTo x y z == <x y ..  z>```"+    ]++conditionalFunctions :: Map.Map Text AnnotatedExpression+conditionalFunctions =+  Map.unions+    [ "(==)"+        === toExp (eq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)+        <:: "Eq a => a -> a -> Number"+        --| "equality",+      "(>=)"+        === toExp (geq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)+        <:: "Number -> Number -> Number"+        --| "greater or equal",+      "(<=)"+        === toExp (leq :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)+        <:: "Number -> Number -> Number"+        --| "less or equal",+      "(<)"+        === toExp (ge :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)+        <:: "Number -> Number -> Number"+        --| "less",+      "(>)"+        === toExp (le :: Zwirn Expression -> Zwirn Expression -> Zwirn Bool)+        <:: "Number -> Number -> Number"+        --| "greater",+      "not"+        === toExp (Z.not :: Zwirn Bool -> Zwirn Bool)+        <:: "Number -> Number"+        --| "logical not",+      "(&&)"+        === toExp (Z.and :: Zwirn Bool -> Zwirn Bool -> Zwirn Bool)+        <:: "Number -> Number -> Number"+        --| "logical and",+      "(||)"+        === toExp (Z.or :: Zwirn Bool -> Zwirn Bool -> Zwirn Bool)+        <:: "Number -> Number -> Number"+        --| "logical or",+      "ifthen"+        === toExp (ifthen :: Zwirn Bool -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a -> a"+        --| "choose between two expressions based on a condition",+      "if"+        === toExp (iff :: Zwirn Bool -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "if condition is true produce the value, silence otherwise",+      "while"+        === toExp (while :: Zwirn Bool -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> a) -> a -> a"+        --| "apply function while condition is true",+      "everyFor"+        === toExp (everyFor :: Zwirn Time -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> (a -> a) -> a -> a"+        --| "apply function periodically for a given amount of time",+      "every"+        === toExp (every :: Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> a) -> a -> a"+        --| "apply function periodically for one cycle",+      "everyBeat"+        === toExp (everyBeat :: Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> a) -> a -> a"+        --| "apply function every nth beat",+      "everyBeatShift"+        === toExp (everyBeatShift :: Zwirn Time -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> (a -> a) -> a -> a"+        --| "apply function every nth beat, shifted in time"+    ]++cordFunctions :: Map.Map Text AnnotatedExpression+cordFunctions =+  Map.unions+    [ "pick"+        === toExp (pick :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "pick a certain layer of a cord using an index statring from 0. wraps around if the depth is exceeded",+      "inhabit"+        === toExp (inhabit :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "",+      "select"+        === toExp (select :: Zwirn Double -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "select a certain layer of a cord using a number between 0 and 1",+      "insert"+        === toExp (C.insert :: Zwirn Int -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a -> a"+        --| "insert into a specific layer of a cord",+      "push"+        === toExp (C.push :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "a -> a -> a"+        --| "push on top of a cord",+      "(&)"+        === toExp (C.concat :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "a -> a -> a"+        --| "concat two cords",+      "concat"+        === toExp (C.concat :: Zwirn Expression -> Zwirn Expression -> Zwirn Expression)+        <:: "a -> a -> a"+        --| "concat two cords",+      "pop"+        === toExp (C.pop :: Zwirn Expression -> Zwirn Expression)+        <:: "a -> a"+        --| "remove the top value of a cord",+      "remove"+        === toExp (remove :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "remove a specific layer of a cord",+      "filter"+        === toExp (C.filter :: Zwirn (Zwirn Expression -> Zwirn Bool) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> Number) -> a -> a"+        --| "filter with a predicate",+      "take"+        === toExp (C.take :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "take the first n items of a cord",+      "drop"+        === toExp (C.drop :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "drop the first n items of a cord",+      "replicate"+        === toExp (C.replicate :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "layer the same item n times",+      "superimpose"+        === toExp (superimpose :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> a) -> a -> a"+        --| "```superimpose f x = [(f x), x]```",+      "ghostWith"+        === toExp (ghostWith :: Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> a) -> a -> a"+        --| "```ghostWith n f x = [(shift (n |* 1.5) $ f x), (shift (n |* 2.5) $ f x), x]```",+      "arp"+        === toExp (arp :: Zwirn Expression -> Zwirn Expression)+        <:: "a -> a"+        --| "arpeggiate",+      "reverse"+        === toExp (C.reverse :: Zwirn Expression -> Zwirn Expression)+        <:: "a -> a"+        --| "reverse order of cord",+      "invert"+        === toExp (C.invert :: Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number"+        --| "chord inversion",+      "rotate"+        === toExp (C.rotate :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> a -> a"+        --| "cord rotation",+      "expand"+        === toExp (C.expand :: Zwirn Int -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> Number"+        --| "cord expansion",+      "open"+        === toExp (C.open :: Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number"+        --| "open cord",+      "cat"+        === toExp (cordcat :: Zwirn Expression -> Zwirn Expression)+        <:: "a -> a"+        --| "```cat [x, y, .. z] == [x y .. z]```",+      "timerun"+        === toExp (timerun :: Zwirn Time -> Zwirn Int)+        <:: "Number -> Number"+        --| "",+      "map"+        === toExp (cordmap :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "```map f [x, y, .. z] == [(f x), (f y), .. (f z)```]",+      "layer"+        === toExp (layer :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "(a -> b) -> a -> b"+        --| "```layer [f, g, .. h] x == [(f x), (g x), .. (h x)```]",+      "echoWith"+        === toExp (echoWith :: Zwirn Int -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> (a -> b) -> a -> b"+        --| "",+      "followWith"+        === toExp (followWith :: Zwirn Int -> Zwirn Time -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> Number -> (a -> b) -> a -> b"+        --| "",+      "fold"+        === 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",+      "smooth"+        === toExp (interpol :: Zwirn Time -> Zwirn Time)+        <:: "Number -> Number"+        --| "linear interpolation of items in a cord",+      "depth"+        === toExp (depth :: Zwirn Expression -> Zwirn Int)+        <:: "a -> Number"+        --| "the depth of a cord",+      "at"+        === toExp (at :: Zwirn Int -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression)+        <:: "Number -> (a -> a) -> a -> a"+        --| "apply a function to a specific layer of a cord",+      "cordFromTo"+        === toExp (enumFromToStack :: Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number"+        --| "```cordFromTo x y == [x, .. y]```",+      "cordFromThenTo"+        === toExp (enumFromThenToStack :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)+        <:: "Number -> Number -> Number -> Number"+        --| "```cordFromThenTo x y z == [x, y .. z]```"+    ]++mapFunctions :: Map.Map Text AnnotatedExpression+mapFunctions =+  Map.unions+    [ "pN"+        === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Double -> Zwirn Expression)+        <:: "Text -> Number -> Map"+        --| "number singleton with specific key",+      "pI"+        === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Int -> Zwirn Expression)+        <:: "Text -> Number -> Map"+        --| "integer singleton with specific key",+      "pT"+        === toExp ((\t -> fmap toExp . singleton t) :: Zwirn Text -> Zwirn Text -> Zwirn Expression)+        <:: "Text -> Text -> Map"+        --| "text singleton with specific key",+      "(#)"+        === toExp (union :: Zwirn ExpressionMap -> Zwirn ExpressionMap -> Zwirn ExpressionMap)+        <:: "Map -> Map -> Map"+        --| "union of two maps - structure from the left",+      "lookupN"+        === toExp (M.lookup :: Zwirn Text -> Zwirn ExpressionMap -> Zwirn Expression)+        <:: "Text -> Map -> Number"+        --| "retrieve number at given key or silence if key is missing or it's value not a number",+      "lookupT"+        === toExp (M.lookup :: Zwirn Text -> Zwirn ExpressionMap -> Zwirn Expression)+        <:: "Text -> Map -> Text"+        --| "retrieve text at given key or silence if key is missing or it's value not a text",+      "fix"+        === 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"+        --| "thanks yaxu",+      "jux"+        === toExp (jux :: Zwirn (Zwirn ExpressionMap -> Zwirn ExpressionMap) -> Zwirn ExpressionMap -> Zwirn ExpressionMap)+        <:: "(Map -> Map) -> Map -> Map"+        --| "thanks yaxu",+      "echo"+        === 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 =+  Map.unions+    [ "replace"+        === toExp (replace str)+        <:: "Id a => a -> Map -> Action"+        --| "replace the channel running with given id",+      "target"+        === toExp target+        <:: "Id a => Text -> a -> Map"+        --| "specify a specific target",+      "($:)"+        === toExp (replace str)+        <:: "Id a => a -> Map -> Action"+        --| "replace the channel running with given id",+      "replaceAction"+        === toExp (replaceAction str)+        <:: "Id a => a -> Action -> Action"+        --| "replace the channel running with given id",+      "($!)"+        === toExp (replaceAction str)+        <:: "Id a => a -> Action -> Action"+        --| "replace the channel running with given id",+      "replaceBus"+        === toExp (replaceBus str)+        <:: "Id a => a -> Number -> Action"+        --| "replace the bus running with given id",+      "(&:)"+        === toExp (replaceBus str)+        <:: "Id a => a -> Number -> Action"+        --| "replace the bus running with given id",+      "fx"+        === toExp (fx str)+        <:: "Id a => a -> (Map -> Map) -> Action"+        --| "apply the function to channel with given id",+      "(#!)"+        === toExp (fx str)+        <:: "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",+      "tempo"+        === toExp tempo+        <:: "Number"+        --| "current tempo in bpm",+      "bpc"+        === toExp bpc+        <:: "Number"+        --| "current beats per cycle",+      "hush"+        === toExp (hush str)+        <:: "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)+        <:: "Id a => a -> Action"+        --| "mute channel with given id",+      "unmute"+        === toExp (unmute str)+        <:: "Id a => a -> Action"+        --| "unmute channel with given id",+      "toggle"+        === toExp (toggle str)+        <:: "Id a => a -> Action"+        --| "toggle channel with given id",+      "solo"+        === toExp (solo str)+        <:: "Id a => a -> Action"+        --| "solo channel with given id",+      "unsolo"+        === toExp (unsolo str)+        <:: "Id a => a -> Action"+        --| "unsolo channel with given id",+      "togglesolo"+        === toExp (togglesolo str)+        <:: "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)+        <:: "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"+        --| ""+    ]
+ src/zwirn-lang/Zwirn/Language/Compiler.hs view
@@ -0,0 +1,526 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Zwirn.Language.Compiler where++{-+    Compiler.hs - implementation of a compiler-interpreter for zwirn+    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 Control.Concurrent (readMVar)+import Control.Exception (SomeException, try)+import Control.Monad+import Control.Monad.Except+import Control.Monad.State+import Data.Either (lefts, rights)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+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.Language.Block+import Zwirn.Language.Builtin.Prelude (builtinEnvironmentWithStream, builtinNames)+import Zwirn.Language.Environment+import Zwirn.Language.Evaluate+import Zwirn.Language.Location+import Zwirn.Language.Macro+import Zwirn.Language.Parser+import Zwirn.Language.Pretty+import qualified Zwirn.Language.Rotate as R+import Zwirn.Language.Simple+import Zwirn.Language.Syntax+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+  = CIMessage Text+  deriving (Show, Eq)++data CurrentBlock+  = CurrentBlock Int Int+  deriving (Eq, Show)++data ConfigEnv+  = ConfigEnv+  { cConfigPath :: IO String,+    cResetConfig :: IO String+  }++data CiConfig = CiConfig+  { ciConfigOverwriteBuiltin :: Bool,+    ciConfigDynamicTypes :: Bool+  }++data Environment+  = Environment+  { tStream :: Stream,+    intEnv :: InterpreterEnv,+    confEnv :: Maybe ConfigEnv,+    ciConfig :: CiConfig,+    macroMap :: MacroMap+  }++data ErrorType+  = ParseErr String RealSrcLoc+  | TypeErr TypeError+  | RotErr R.RotationError+  | OtherErr String+  | ManyErr [ErrorType]++instance Show ErrorType where+  show (ParseErr s _) = s+  show (TypeErr err) = unpack $ render err+  show (RotErr err) = show err+  show (OtherErr err) = err+  show (ManyErr errs) = intercalate "\n" $ map show errs++data CIError+  = CIError+  { eError :: ErrorType,+    eEnv :: Environment+  }++data CompilerOutput+  = OutMessage Text+  | OutEdits [CodeEdit]+  | NoOutput+  deriving (Eq, Show)++instance Show CIError where+  show (CIError err _) = show err++type CI = StateT Environment (ExceptT CIError IO)++runCI :: Environment -> CI a -> IO (Either CIError a)+runCI env m = runExceptT $ evalStateT m env++debug :: (MonadIO m) => String -> m ()+debug msg = liftIO $ hPutStrLn stderr $ "[zwirnzi] " <> msg++compilerInterpreterBasic :: Text -> CI CompilerOutput+compilerInterpreterBasic input = do+  sy <- runParser input+  runSyntax True sy++compilerInterpreterBlock :: Int -> Text -> CI (CompilerOutput, Environment)+compilerInterpreterBlock 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)++compilerInterpreterLine :: Int -> Text -> CI (CompilerOutput, Environment)+compilerInterpreterLine line input = do+  blocks <- runBlocks 0 input+  content <- runGetLine line blocks+  sy <- runParserWithPos line "" content+  r <- runSyntax True sy+  e <- get+  return (r, e)++compilerInterpreterWhole :: Text -> CI (CompilerOutput, Environment)+compilerInterpreterWhole input = do+  blocks <- runBlocks 0 input+  syss <- mapM parseBlock blocks+  rs <- mapM (runSyntax True) $ concat syss+  e <- get+  return (last rs, e)++compilerInterpreterBoot :: [Text] -> CI Environment+compilerInterpreterBoot ps = mapM_ (runSyntax False . Command . noLoc . LoadCommand) ps >> get++-----------------------------------------------------+----------------- Throwing Errors -------------------+-----------------------------------------------------++throw :: ErrorType -> CI a+throw err = do+  env <- get+  throwError $ CIError err env++-- | catches an error by wrapping the result back into Either+catch :: CI a -> CI (Either CIError a)+catch c = catchError (fmap Right c) (return . Left)++-- | sequences the given actions, accumulating any occuring errors and wrapping them into ManyErr+catchMany :: [CI a] -> CI [a]+catchMany cs = do+  es <- mapM catch cs+  let errs = lefts es+      vs = rights es+  case errs of+    [] -> return ()+    [e] -> throw $ eError e+    xs -> throw (ManyErr $ map eError xs)+  return vs++filterErrors :: [CI a] -> CI [a]+filterErrors cs = do+  es <- mapM catch cs+  return $ rights es++-----------------------------------------------------+---------------------- Parser -----------------------+-----------------------------------------------------++extractParseErrPos :: String -> ErrorType+extractParseErrPos s = case mpos of+  Just p -> ParseErr s p+  Nothing -> OtherErr s+  where+    (ls, rs) = break (== ',') $ drop 20 s+    (c1s, _) = break (== '\n') $ drop 9 rs+    mpos = do+      l <- readMaybe ls+      c1 <- readMaybe c1s+      return (RealSrcLoc "" l c1 l c1)++runParserWithPos :: Int -> Text -> Text -> CI Syntax+runParserWithPos ln srcp t = case parseSyntaxWithPos ln srcp t of+  Left err -> throw $ extractParseErrPos err+  Right s -> return s++runParser :: Text -> CI Syntax+runParser t = case parseSyntax t of+  Left err -> throw $ extractParseErrPos err+  Right s -> return s++runBlocks :: Int -> Text -> CI [Block]+runBlocks ln t = case parseBlocks ln t of+  Left err -> throw $ OtherErr err+  Right bs -> return bs++runGetBlock :: Int -> [Block] -> CI Block+runGetBlock i bs = case getBlock i bs of+  Left err -> throw $ OtherErr err+  Right b -> return b++runGetLine :: Int -> [Block] -> CI Text+runGetLine i bs = case getSingleLine i bs of+  Left err -> throw $ OtherErr err+  Right (Line _ _ c) -> return c++parseBlock :: Block -> CI [Syntax]+parseBlock (Block ls) = catchMany $ map (\l -> runParserWithPos (lStart l) "" (lContent l)) (NE.toList ls)++getSyntaxLine :: Int -> Text -> CI (Maybe Syntax)+getSyntaxLine ln input = do+  blocks <- runBlocks 0 input+  case getSingleLine ln blocks of+    Right line -> Just <$> runParserWithPos (lStart line) "" (lContent line)+    Left _ -> return Nothing++getSyntaxBlock :: Int -> Text -> CI [Syntax]+getSyntaxBlock ln input = do+  blocks <- runBlocks 0 input+  block <- runGetBlock ln blocks+  parseBlock block++-----------------------------------------------------+---------------------- Macro ------------------------+-----------------------------------------------------++macroCI :: LocTerm -> CI (LocTerm, [CodeEdit])+macroCI t = do+  mmap <- gets macroMap+  case runMacros t mmap of+    Just x -> return x+    _ -> throw $ OtherErr "Unknown macro!"++-----------------------------------------------------+---------------------- Desugar ----------------------+-----------------------------------------------------++runSimplify :: LocTerm -> CI LocSimpleTerm+runSimplify t = return $ simplifyLoc t++runSimplifyDef :: Located Definition -> CI (Located SimpleDef, [CodeEdit])+runSimplifyDef (Located p (Definition x vs t)) = do+  (t', es) <- macroCI t+  return (Located p (LetS x (noLoc $ simplify $ TLambda vs t')), es)++-----------------------------------------------------+------------------- AST Rotation --------------------+-----------------------------------------------------++runRotate :: LocSimpleTerm -> CI LocSimpleTerm+runRotate s = case R.runRotate s of+  Left err -> throw $ RotErr err+  Right t -> return t++-----------------------------------------------------+-------------------- Type Check ---------------------+-----------------------------------------------------++runTypeCheck :: LocSimpleTerm -> CI Scheme+runTypeCheck s = do+  Environment {intEnv = env} <- get+  case inferTerm env s of+    Left err -> throw (TypeErr err)+    Right t -> return t++-----------------------------------------------------+-------------------- Interpreter --------------------+-----------------------------------------------------++interpret :: LocSimpleTerm -> CI Expression+interpret input = do+  env <- gets intEnv+  return $ evaluate env input++-- if ctx is false, highlighting should be disabled+checkHighlight :: Bool -> Expression -> CI Expression+checkHighlight True x = return x+checkHighlight False x = return $ removePosExp x++-----------------------------------------------------+----------------- Checking Options  -----------------+-----------------------------------------------------++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."++dynamicOk :: Text -> Scheme -> CI ()+dynamicOk name ty = do+  dynamic <- gets (ciConfigDynamicTypes . ciConfig)+  mayty <- gets (lookupType name . intEnv)+  case mayty of+    Just oldType ->+      when (not dynamic && not (unifiable (schemeToType oldType, schemeToType ty))) $ throw $ OtherErr "Cannot overwrite definition with new type. Please use DynamicTypes."+    Nothing -> return ()++-------------------------------------------------------+----------------- Interpreting Syntax -----------------+-------------------------------------------------------++runSyntax :: Bool -> Syntax -> CI CompilerOutput+runSyntax b (Exec t) = executeTerm b t+runSyntax _ (Command c) = runCommand (lValue c)+runSyntax b (Def d) = define b d+runSyntax b (DynDef d) = dynamicDefine b (lValue d)+runSyntax _ (MacroDef d) = macroDefine (lValue d)++executeTerm :: Bool -> LocTerm -> CI CompilerOutput+executeTerm ctx t = do+  (t', es) <- macroCI t+  s <- runSimplify t'+  rot <- runRotate s+  ty <- runTypeCheck rot+  ex <- interpret rot+  exCtx <- checkHighlight ctx ex+  case ty of+    Forall _ (Qual _ _ (TypeCon "Action")) -> do+      str <- gets tStream+      liftIO $ evalAction str (fromExp exCtx)+      return $ OutEdits es+    _ -> throw $ OtherErr "Can only execute actions!"++define :: Bool -> Located Definition -> CI CompilerOutput+define ctx d = do+  (Located _ (LetS x st), es) <- runSimplifyDef d+  rot <- runRotate st+  ty <- runTypeCheck rot+  ex <- interpret rot+  exCtx <- checkHighlight ctx ex+  overwriteOk x+  dynamicOk x ty+  modify (\env -> env {intEnv = extend (x, exCtx, ty) (intEnv env)})+  return $ OutEdits es++dynamicDefine :: Bool -> DynamicDefinition -> CI CompilerOutput+dynamicDefine ctx (DynamicDefinition x t) = do+  (t', es) <- macroCI t+  s <- runSimplify t'+  rot <- runRotate s+  ty <- runTypeCheck rot+  ex <- interpret rot+  exCtx <- checkHighlight ctx ex+  overwriteOk x+  dynamicOk x ty+  setExpression x ty exCtx+  return $ OutEdits es++macroDefine :: MacroDefinition -> CI CompilerOutput+macroDefine (MacroDefinition x t) = do+  (t', es) <- macroCI t+  s <- runSimplify t'+  rot <- runRotate s+  _ <- runTypeCheck rot+  modify (\env -> env {macroMap = Map.insert x t' (macroMap env)})+  return $ OutEdits es++setExpression :: Text -> Scheme -> Expression -> CI ()+setExpression x ty exCtx+  | isBasicType ty = do+      if checkDependency x ty+        then do+          let newEx+                | isNumberT ty = EZwirn $ getStateN (pure x)+                | isTextT ty = EZwirn $ getStateT (pure x)+                | 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+        else throw $ OtherErr "Cyclic dependency detected!"+  | otherwise = throw $ OtherErr "Can only set basic types!"++---------------------------------------------------------+----------------- Interpreting Commands -----------------+---------------------------------------------------------++runCommand :: Command -> CI CompilerOutput+runCommand (ShowCommand t) = showCommand t+runCommand (TypeCommand t) = typeCommand t+runCommand (SetCommand f) = setCommand (unpack f)+runCommand (UnsetCommand _) = return NoOutput+runCommand (LoadCommand f) = NoOutput <$ loadCommand f+runCommand (InfoCommand f) = infoCommand f+runCommand ResetEnvCommand = resetEnvCommand+runCommand ResetConfigCommand = resetConfigCommand+runCommand ShowConfigPathCommand = showConfigPathCommand+runCommand StatusCommand = statusCommand+runCommand EnvCommand = envCommand++showCommand :: LocTerm -> CI CompilerOutput+showCommand t = do+  (t', _) <- macroCI t+  s <- runSimplify t'+  rot <- runRotate s+  ty <- runTypeCheck rot+  if isBasicType ty+    then do+      ex <- interpret rot+      stmv <- gets (sState . tStream)+      prec <- gets (streamConfigPrecision . sConfig . tStream)+      st <- liftIO $ readMVar stmv+      return $ OutMessage $ pack $ showWithStatePrec (realToFrac prec) st ex+    else throw $ OtherErr $ "Can not show expressions of type: " ++ unpack (ppscheme ty)++typeCommand :: LocTerm -> CI CompilerOutput+typeCommand t = do+  (t', _) <- macroCI t+  s <- runSimplify t'+  rot <- runRotate s+  ty <- runTypeCheck rot+  return $ OutMessage $ ppTermHasType (t, ty)++loadCommand :: Text -> CI ()+loadCommand path = do+  mayfile <- liftIO ((try $ readFile $ unpack path) :: IO (Either SomeException Text))+  case mayfile of+    Left _ -> throw $ OtherErr "File not found"+    Right input -> do+      blocks <- runBlocks 0 input+      let content = concatMap getBlockContent blocks+      ss <- mapM runParser content+      mapM_ (runSyntax False) ss++infoCommand :: Text -> CI CompilerOutput+infoCommand n = do+  env <- gets intEnv+  case lookupFull n env of+    Just (Annotated _ t (Just d)) -> return $ OutMessage $ n <> " :: " <> ppscheme t <> "  \n" <> d+    Just (Annotated _ t Nothing) -> return $ OutMessage $ n <> " :: " <> ppscheme t+    Nothing -> return $ OutMessage $ pack $ "Couldn't find information about " ++ unpack n++resetConfigCommand :: CI CompilerOutput+resetConfigCommand = do+  (Environment {confEnv = mayEnv}) <- get+  case mayEnv of+    Nothing -> throw $ OtherErr "Configuration not available."+    Just (ConfigEnv _ reset) -> OutMessage . pack <$> liftIO reset++showConfigPathCommand :: CI CompilerOutput+showConfigPathCommand = do+  (Environment {confEnv = mayEnv}) <- get+  case mayEnv of+    Nothing -> throw $ OtherErr "Configuration not available."+    Just (ConfigEnv path _) -> OutMessage . pack <$> liftIO path++resetEnvCommand :: CI CompilerOutput+resetEnvCommand = do+  str <- gets tStream+  modify (\env -> env {intEnv = builtinEnvironmentWithStream str})+  return $ OutMessage "Environment reset to default!"++setCommand :: String -> CI CompilerOutput+setCommand "DynamicTypes" = modify (\env -> env {ciConfig = (ciConfig env) {ciConfigDynamicTypes = True}}) >> return (OutMessage "Successfully enabled DynamicTypes.")+setCommand "OverwriteBuiltin" = modify (\env -> env {ciConfig = (ciConfig env) {ciConfigOverwriteBuiltin = True}}) >> return (OutMessage "Successfully enabled OverwriteBuiltin.")+setCommand _ = return $ OutMessage "Unknown compiler flag. The flags are: DynamicTypes, OverwriteBuiltin."++-- for now only prints out the "basic" non-builtin expressions+-- TODO: add a flag/modifier to print all expressions (via :env all)+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+      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+  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++isNumberT :: Scheme -> Bool+isNumberT (Forall _ (Qual _ _ (TypeCon "Number"))) = True+isNumberT _ = False++isTextT :: Scheme -> Bool+isTextT (Forall _ (Qual _ _ (TypeCon "Text"))) = True+isTextT _ = False++isMapT :: Scheme -> Bool+isMapT (Forall _ (Qual _ _ (TypeCon "Map"))) = True+isMapT _ = False
+ src/zwirn-lang/Zwirn/Language/Environment.hs view
@@ -0,0 +1,47 @@+module Zwirn.Language.Environment where++import qualified Data.Map as Map+import Data.Text (Text)+import Zwirn.Core.Types (silence)+import Zwirn.Language.Evaluate.Expression+import Zwirn.Language.TypeCheck.Types++data AnnotatedExpression+  = Annotated+  { aExp :: Expression,+    aType :: Scheme,+    aDesc :: Maybe Text+  }++data InterpreterEnv = IEnv+  { eExpressions :: Map.Map Text AnnotatedExpression,+    eInstances :: [Instance]+  }++withExpressions :: (Map.Map Text AnnotatedExpression -> Map.Map Text AnnotatedExpression) -> InterpreterEnv -> InterpreterEnv+withExpressions f (IEnv l i) = IEnv (f l) i++extend :: (Text, Expression, Scheme) -> InterpreterEnv -> InterpreterEnv+extend (n, x, s) = withExpressions (Map.insert n (Annotated x s Nothing))++lookupType :: Text -> InterpreterEnv -> Maybe Scheme+lookupType k (IEnv l _) = aType <$> Map.lookup k l++insertType :: Text -> Scheme -> InterpreterEnv -> InterpreterEnv+insertType t s = withExpressions (Map.alter alt t)+  where+    dummy = EZwirn silence+    alt Nothing = Just $ Annotated dummy s Nothing+    alt (Just (Annotated x _ i)) = Just $ Annotated x s i++lookupDescription :: Text -> InterpreterEnv -> Maybe Text+lookupDescription k (IEnv l _) = aDesc =<< Map.lookup k l++lookupExp :: Text -> InterpreterEnv -> Maybe Expression+lookupExp k (IEnv l _) = aExp <$> Map.lookup k l++lookupFull :: Text -> InterpreterEnv -> Maybe AnnotatedExpression+lookupFull k (IEnv l _) = Map.lookup k l++isBasicExpression :: AnnotatedExpression -> Bool+isBasicExpression (Annotated _ s _) = isBasicType s
+ src/zwirn-lang/Zwirn/Language/Evaluate.hs view
@@ -0,0 +1,12 @@+module Zwirn.Language.Evaluate+  ( module Zwirn.Language.Evaluate.Expression,+    module Zwirn.Language.Evaluate.Internal,+    module Zwirn.Language.Evaluate.Convert,+    module Zwirn.Language.Evaluate.SKI,+  )+where++import Zwirn.Language.Evaluate.Convert+import Zwirn.Language.Evaluate.Expression+import Zwirn.Language.Evaluate.Internal+import Zwirn.Language.Evaluate.SKI
+ src/zwirn-lang/Zwirn/Language/Evaluate/Convert.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Zwirn.Language.Evaluate.Convert where++{-+    Convert.hs - convert from and to Expressions+    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 qualified Data.Map as Map+import Data.String (IsString, fromString)+import Data.Text (Text, pack, unpack)+import Zwirn.Core.Time (Time (..))+import Zwirn.Core.Types+import Zwirn.Language.Evaluate.Expression++fromZwirn :: Zwirn Expression -> Expression+fromZwirn = EZwirn++toZwirn :: Expression -> Zwirn Expression+toZwirn (EZwirn x) = x+toZwirn _ = silence++class FromExpression a where+  fromExp :: Expression -> Zwirn a++class ToExpression a where+  toExp :: a -> Expression++instance FromExpression Time where+  fromExp (EZwirn tz) = fmap (\(ENum t) -> Time (toRational t) 0) tz+  fromExp _ = silence++instance FromExpression Double where+  fromExp (EZwirn tz) = fmap (\(ENum t) -> t) tz+  fromExp _ = silence++instance FromExpression Int where+  fromExp (EZwirn tz) = fmap (\(ENum t) -> floor t) tz+  fromExp _ = silence++instance FromExpression Expression where+  fromExp (EZwirn z) = z+  fromExp _ = silence++instance FromExpression Text where+  fromExp (EZwirn z) = fmap (\(EText t) -> t) z+  fromExp _ = silence++instance FromExpression String where+  fromExp (EZwirn z) = fmap (\(EText t) -> unpack t) z+  fromExp _ = silence++instance FromExpression Bool where+  fromExp (EZwirn z) = fmap (\(ENum x) -> x >= 1) z+  fromExp _ = silence++instance FromExpression (IO ()) where+  fromExp (EZwirn z) = fmap (\(EAction x) -> x) z+  fromExp _ = silence++instance FromExpression ExpressionMap where+  fromExp (EZwirn z) = fmap (\(EMap m) -> m) z+  fromExp _ = silence++instance (ToExpression a, FromExpression b) => FromExpression (Zwirn a -> Zwirn b) where+  fromExp (EZwirn z) = fmap (\(ELam f) -> fromExp . f . toExp) z+  fromExp _ = silence++instance (FromExpression a) => FromExpression (Zwirn a) where+  fromExp (EZwirn z) = fmap fromExp z+  fromExp _ = silence++instance ToExpression Expression where+  toExp = id++instance ToExpression Double where+  toExp = ENum++instance ToExpression String where+  toExp = EText . pack++instance ToExpression (IO ()) where+  toExp = EAction++instance ToExpression Time where+  toExp (Time t _) = ENum $ fromRational t++instance ToExpression Int where+  toExp i = ENum $ fromIntegral i++instance ToExpression Bool where+  toExp True = ENum 1+  toExp False = ENum 0++instance ToExpression Text where+  toExp = EText++instance (ToExpression a) => ToExpression (Map.Map Text a) where+  toExp m = EMap $ toExp <$> m++instance (ToExpression a) => ToExpression (Zwirn a) where+  toExp a = EZwirn $ fmap toExp a++instance (FromExpression a, ToExpression b) => ToExpression (Zwirn a -> b) where+  toExp f = lambda $ \x -> toExp $ f (fromExp x)++instance Num Expression where+  (+) = pervasive2 ((+) @Double)+  (*) = pervasive2 ((*) @Double)+  abs = pervasive (abs @Double)+  signum = pervasive (signum @Double)+  fromInteger i = ENum $ fromInteger i+  negate = pervasive (negate @Double)++instance Fractional Expression where+  fromRational r = ENum $ fromRational r+  (/) = pervasive2 ((/) @Double)++instance Floating Expression where+  pi = EZwirn $ pure $ ENum pi+  exp = pervasive (exp :: Double -> Double)+  log = pervasive (log :: Double -> Double)+  sin = pervasive (sin :: Double -> Double)+  cos = pervasive (cos :: Double -> Double)+  asin = pervasive (asin :: Double -> Double)+  acos = pervasive (acos :: Double -> Double)+  atan = pervasive (atan :: Double -> Double)+  sinh = pervasive (sinh :: Double -> Double)+  cosh = pervasive (cosh :: Double -> Double)+  asinh = pervasive (asinh :: Double -> Double)+  acosh = pervasive (acosh :: Double -> Double)+  atanh = pervasive (atanh :: Double -> Double)++instance IsString Expression where+  fromString = EText . pack++class Pervasive a where+  pervasive :: (a -> a) -> Expression -> Expression+  pervasive2 :: (a -> a -> a) -> Expression -> Expression -> Expression++instance Pervasive Double where+  pervasive f (ENum d) = ENum $ f d+  pervasive f (EMap m) = EMap $ fmap (pervasive f) m+  pervasive _ e = e+  pervasive2 f (ENum d) (ENum e) = ENum $ f d e+  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n+  pervasive2 _ e _ = e++instance Pervasive Bool where+  pervasive f (ENum d) = toExp $ f (d >= 1)+  pervasive f (EMap m) = EMap $ fmap (pervasive f) m+  pervasive _ e = e+  pervasive2 f (ENum d) (ENum e) = toExp $ f (d >= 1) (e >= 1)+  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n+  pervasive2 _ e _ = e++instance Pervasive Text where+  pervasive f (EText d) = EText $ f d+  pervasive f (EMap m) = EMap $ fmap (pervasive f) m+  pervasive _ e = e+  pervasive2 f (EText d) (EText e) = EText $ f d e+  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n+  pervasive2 _ e _ = e++instance Pervasive (Either Double Text) where+  pervasive f (EText d) = EText $ (\(Right t) -> t) $ f (Right d)+  pervasive f (ENum d) = ENum $ (\(Left t) -> t) $ f (Left d)+  pervasive f (EMap m) = EMap $ fmap (pervasive f) m+  pervasive _ e = e+  pervasive2 f (EText d) (EText e) = EText $ (\(Right t) -> t) $ f (Right d) (Right e)+  pervasive2 f (ENum d) (ENum e) = ENum $ (\(Left t) -> t) $ f (Left d) (Left e)+  pervasive2 f (EMap m) (EMap n) = EMap $ Map.unionWith (pervasive2 f) m n+  pervasive2 _ e _ = e
+ src/zwirn-lang/Zwirn/Language/Evaluate/Expression.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Zwirn.Language.Evaluate.Expression where++{-+    Expression.hs - Abstract Expressions+    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 Data.List (intercalate)+import qualified Data.Map as Map+import Data.Text (Text, unpack)+import Zwirn.Core.Cord+import Zwirn.Core.Query+import Zwirn.Core.Time (Time (..))+import Zwirn.Language.Location (SrcLoc)+import Zwirn.Language.Syntax++type ExpressionMap = Map.Map Text Expression++type Zwirn = Cord ExpressionMap SrcLoc++data Expression+  = EVar LocVar+  | EApp Expression Expression+  | ELam (Expression -> Expression)+  | ENum !Double+  | EText !Text+  | EMap ExpressionMap+  | EAction (IO ())+  | ESeq [Expression]+  | EStack [Expression]+  | EChoice Int [Expression]+  | EZwirn (Zwirn Expression)++showWithStatePrec :: Time -> ExpressionMap -> Expression -> String+showWithStatePrec prec st (EZwirn x) = intercalate "\n" $ (\(t, y) -> show t ++ ":" ++ showWithStatePrec prec st y) <$> findAllValuesWithTimePrec prec (Time 0 1, Time 1 1) st x+showWithStatePrec _ _ (ENum x) = show $ (fromIntegral (floor (x * 10 ^ (5 :: Int)) :: Int) :: Double) / 10 ^ (5 :: Int)+showWithStatePrec _ _ (EText x) = unpack x+showWithStatePrec _ _ (EAction _) = "action"+showWithStatePrec prec st (EMap m) = show $ Map.toList $ showWithStatePrec prec st <$> m+showWithStatePrec _ _ (EVar x) = show x+showWithStatePrec _ _ (EApp x y) = "(" ++ show x ++ " " ++ show y ++ ")"+showWithStatePrec _ _ (ESeq xs) = "[" ++ unwords (map show xs) ++ "]"+showWithStatePrec _ _ (EStack xs) = "[" ++ intercalate "," (map show xs) ++ "]"+showWithStatePrec _ _ (EChoice _ xs) = "[" ++ intercalate "|" (map show xs) ++ "]"+showWithStatePrec _ _ _ = "can't show"++instance Show Expression where+  show = showWithStatePrec 0.005 Map.empty++instance Eq Expression where+  (==) (ENum n) (ENum m) = n == m+  (==) (EText n) (EText m) = n == m+  (==) (EMap n) (EMap m) = n == m+  (==) _ _ = False++instance Ord Expression where+  (<=) (ENum n) (ENum m) = n <= m+  (<=) _ _ = False++lambda :: (Expression -> Expression) -> Expression+lambda f = EZwirn $ pure $ ELam f
+ src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-unused-imports #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Zwirn.Language.Evaluate.Internal where++{-+    Internal.hs - internal functions, specific to Expressions+    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 Control.Applicative (liftA2)+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (void)+import Data.Fixed (mod')+import Data.List (mapAccumL)+import qualified Data.Map as Map+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+import Zwirn.Core.Lib.Core (apply)+import Zwirn.Core.Lib.Map+import Zwirn.Core.Lib.State+import Zwirn.Core.Lib.Structure (segment)+import Zwirn.Core.Time (Time)+import Zwirn.Core.Tree (Tree)+import Zwirn.Core.Types+import Zwirn.Language.Evaluate.Convert+import Zwirn.Language.Evaluate.Expression+import Zwirn.Language.Location (SrcLoc)+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)++insert :: (Text, Expression) -> ExpressionMap -> ExpressionMap+insert (k, x) = Map.insert k x++getStateN :: Zwirn Text -> Zwirn Expression+getStateN xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))+  where+    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromNum x+    fromLookup _ = silence+    fromNum (ENum n) = pure $ ENum n+    fromNum _ = silence++getStateNWith :: Zwirn Text -> Zwirn Expression -> Zwirn Expression+getStateNWith xc z = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))+  where+    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromNum x+    fromLookup _ = z+    fromNum (ENum n) = pure $ ENum n+    fromNum _ = silence++getStateT :: Zwirn Text -> Zwirn Expression+getStateT xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))+  where+    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromText x+    fromLookup _ = silence+    fromText (EText n) = pure $ EText n+    fromText _ = silence++getStateM :: Zwirn Text -> Zwirn Expression+getStateM xc = innerJoin $ liftA2 (\k l -> fromLookup $ Map.lookup k l) xc (get (pure ()))+  where+    fromLookup (Just (EZwirn x)) = outerJoin $ fmap fromMap x+    fromLookup _ = silence+    fromMap (EMap n) = pure $ EMap n+    fromMap _ = silence++modifyState :: Zwirn Text -> Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression+modifyState kz fz xz = (modifyState' <$> kz <*> fz) `apply` xz+  where+    modifyState' :: Text -> (Zwirn Expression -> Zwirn Expression) -> Zwirn Expression -> Zwirn Expression+    modifyState' key f = withState (Map.update (Just . toExp . f . fromExp) key)++setState :: Zwirn Text -> Zwirn Expression -> Zwirn Expression -> Zwirn Expression+setState t x = setMap t (pure $ EZwirn x)++getState :: Zwirn Expression -> Zwirn ExpressionMap+getState = get++bus :: Zwirn Double -> Zwirn Double+bus = segment (pure 128)++segbus :: Zwirn Int -> Zwirn Double -> Zwirn Double+segbus = segment++paramName :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Text+paramName f = headOrDef . Map.keys <$> (fromExp $ EZwirn $ apply f (pure (ENum 0)) :: Zwirn ExpressionMap)+  where+    headOrDef [] = ""+    headOrDef (x : _) = x++recvT :: Zwirn Text -> Zwirn Int -> Zwirn ExpressionMap+recvT t i = singleton t (fmap (toExp . (\x -> pack $ "c" ++ show x)) i)++recv :: Zwirn (Zwirn Expression -> Zwirn Expression) -> Zwirn Int -> Zwirn ExpressionMap+recv f = recvT t+  where+    t = paramName f++------------------------------------+------------- stream ui ------------+------------------------------------++toID :: Expression -> Identifier+toID (ENum i) = NumID (floor i :: Int)+toID (EText t) = TextID t+toID (EMap m) = TextID $ pack $ show m+toID _ = error "Error in toID!"++toBusID :: Zwirn Expression -> Zwirn (Targeted Int)+toBusID ex = innerJoin $ mapper <$> ex+  where+    mapper (ENum i) = pure $ Targeted [] (floor i)+    mapper (EMap mex) = Targeted targs <$> idd+      where+        idd = maybe silence toIDD (Map.lookup "id" mex)+        targs = toTarget <$> Map.elems (Map.delete "id" mex)+        toIDD (ENum i) = pure $ floor i :: Zwirn Int+        toIDD _ = silence+        toTarget (EText t) = t+        toTarget _ = error "Error in toTargetedID!"+    mapper _ = silence++toTargetedID :: Expression -> Targeted Identifier+toTargetedID (EMap mex) = Targeted targs idd+  where+    idd = toID $ fromMaybe (EText "default") $ Map.lookup "id" mex+    targs = toTarget <$> Map.elems (Map.delete "id" mex)+    toTarget (EText t) = t+    toTarget _ = error "Error in toTargetedID!"+toTargetedID ex = Targeted [] (toID ex)++target :: Zwirn Text -> Zwirn Expression -> Zwirn Expression+target tz = liftA2 (\tm idd -> EMap $ Map.insert "id" idd tm) targs+  where+    targs = innerJoin $ foldl (liftA2 (\m t -> Map.insert t (EText t) m)) (pure Map.empty :: Zwirn ExpressionMap) <$> collect tz++tempo :: Zwirn Expression+tempo = getStateN (pure "tempo")++bpc :: Zwirn Expression+bpc = getStateN (pure "_beatsPerCycle")++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++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
+ src/zwirn-lang/Zwirn/Language/Evaluate/SKI.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Zwirn.Language.Evaluate.SKI+  ( evaluate,+    compile,+    (!),+    removePosExp,+  )+where++{-+    SKI.hs - evaluate epxressions via the SKI combinator calculus,+    code adapted from https://kseo.github.io/posts/2016-12-30-write-you-an-interpreter.html+    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 Data.Maybe (fromJust)+import Data.Text (unpack)+import Zwirn.Core.Cord+import Zwirn.Core.Core+import Zwirn.Core.Lib.Core+import Zwirn.Core.Lib.Modulate+import Zwirn.Core.Lib.Random (chooseWithSeed)+import Zwirn.Core.Types+import Zwirn.Language.Environment+import Zwirn.Language.Evaluate.Convert+import Zwirn.Language.Evaluate.Expression+import Zwirn.Language.Location+import Zwirn.Language.Simple+import Zwirn.Language.TypeCheck.Types++compile :: LocSimpleTerm -> Expression+compile (Located p (SVar n)) = EVar (Located p n)+compile (Located _ (SApp fun arg)) = EApp (compile fun) (compile arg)+compile (Located _ (SLambda x body)) = abstract x (compile body)+compile (Located p (SNum x)) = EZwirn $ addInfo p $ pure $ ENum $ read $ unpack x+compile (Located p (SText x)) = EZwirn $ addInfo p $ pure $ EText x+compile (Located _ (SSeq xs)) = ESeq $ map compile xs+compile (Located _ (SStack xs)) = EStack $ map compile xs+compile (Located _ (SChoice i xs)) = EChoice i $ map compile xs+compile (Located _ (SInfix s1 n s2)) = EApp (EApp (EVar n) (compile s1)) (compile s2)+compile (Located _ (SBracket s)) = compile s+compile (Located _ SRest) = EZwirn silence++abstract :: Name -> Expression -> Expression+abstract x (EVar n) | x == lValue n = combI+abstract x (EApp fun arg) = combS (abstract x fun) (abstract x arg)+abstract x (ESeq xs) = ESeq $ map (abstract x) xs+abstract x (EStack xs) = EStack $ map (abstract x) xs+abstract x (EChoice i xs) = EChoice i $ map (abstract x) xs+abstract _ k = combK k++combS :: Expression -> Expression -> Expression+combS f = EApp (EApp (EVar $ noLoc "scomb") f)++combK :: Expression -> Expression+combK = EApp (EVar $ noLoc "const")++combI :: Expression+combI = EVar (noLoc "id")++infixl 0 !++(!) :: Expression -> Expression -> Expression+(EZwirn fp) ! (EZwirn x) = EZwirn $ apply (fmap (\(ELam f) -> toZwirn . f . fromZwirn) fp) x+_ ! _ = error "Error in (!)"++link :: InterpreterEnv -> Expression -> Expression+link bs (EVar n) = addPosExp (lLoc n) $ fromJust (lookupExp (lValue n) bs)+-- link bs (EVar  n) = fromJust (lookupExp n bs)+link bs (EApp f x) = link bs f ! link bs x+link bs (ESeq xs) = EZwirn $ fastcat $ map (toZwirn . link bs) xs+link bs (EStack xs) = EZwirn $ stack $ map (toZwirn . link bs) xs+link bs (EChoice i xs) = EZwirn $ chooseWithSeed i $ map (toZwirn . link bs) xs+link _ e = e++evaluate :: InterpreterEnv -> LocSimpleTerm -> Expression+evaluate bs = link bs . compile++addPosExp :: SrcLoc -> Expression -> Expression+addPosExp p (EZwirn x) = EZwirn $ withInfos (p :) x+addPosExp _ x = x++removePosExp :: Expression -> Expression+removePosExp (EZwirn z) = EZwirn $ removeInfo z+removePosExp x = x
+ src/zwirn-lang/Zwirn/Language/LSP/Diagnostics.hs view
@@ -0,0 +1,42 @@+module Zwirn.Language.LSP.Diagnostics where++import Data.Functor (void)+import qualified Data.Text as T+import Zwirn.Language.Compiler+import Zwirn.Language.Location+import Zwirn.Language.Simple (simplify)+import Zwirn.Language.Syntax++diagnoseCI :: T.Text -> CI ()+diagnoseCI input = do+  blocks <- runBlocks 0 input+  as <- concat <$> catchMany (map parseBlock blocks)+  -- debug' $ T.pack $ show blocks+  void $ catchMany $ map typeCheckAction as++validateCode :: Environment -> T.Text -> IO (Maybe ErrorType)+validateCode env input = do+  out <- runCI env (diagnoseCI input)+  case out of+    Left (CIError err _) -> return $ Just err+    Right _ -> return Nothing++runTypeCheckTerm :: LocTerm -> CI ()+runTypeCheckTerm t = do+  (t', _) <- macroCI t+  s <- runSimplify t'+  rot <- runRotate s+  void $ runTypeCheck rot++typeCheckAction :: Syntax -> CI ()+typeCheckAction (Exec t) = runTypeCheckTerm t+typeCheckAction (Def (Located p (Definition _ vs t))) = do+  (t', _) <- macroCI t+  let st = Located p (simplify $ TLambda vs t')+  rot <- runRotate st+  void $ runTypeCheck rot+typeCheckAction (DynDef (Located _ (DynamicDefinition _ t))) = runTypeCheckTerm t+typeCheckAction (MacroDef (Located _ (MacroDefinition _ t))) = runTypeCheckTerm t+typeCheckAction (Command (Located _ (ShowCommand t))) = runTypeCheckTerm t+typeCheckAction (Command (Located _ (TypeCommand t))) = runTypeCheckTerm t+typeCheckAction (Command _) = return ()
+ src/zwirn-lang/Zwirn/Language/LSP/Eval.hs view
@@ -0,0 +1,20 @@+module Zwirn.Language.LSP.Eval where++import Control.Monad.State (get)+import qualified Data.Text as T+import Zwirn.Language.Compiler+import Zwirn.Language.Macro (CodeEdit)++evalBlockAt :: T.Text -> Int -> CI (([CodeEdit], [T.Text]), Environment)+evalBlockAt doc l = do+  sys <- getSyntaxBlock l doc+  r <- mapM (runSyntax True) sys+  e <- get+  return (getOutput r, e)++getOutput :: [CompilerOutput] -> ([CodeEdit], [T.Text])+getOutput = foldl f ([], [])+  where+    f (es, ms) (OutMessage m) = (es, m : ms)+    f (es, ms) (OutEdits e) = (e ++ es, ms)+    f (es, ms) _ = (es, ms)
+ src/zwirn-lang/Zwirn/Language/LSP/Hover.hs view
@@ -0,0 +1,57 @@+module Zwirn.Language.LSP.Hover where++import Control.Monad.RWS (gets)+import qualified Data.Text as T+import Zwirn.Language.Compiler+import Zwirn.Language.Environment (AnnotatedExpression (..), lookupFull)+import Zwirn.Language.Location+import Zwirn.Language.Pretty (ppscheme)+import Zwirn.Language.Syntax++-- parses source code+parseAndGetInfoAt :: T.Text -> Position -> CI (Maybe (T.Text, RealSrcLoc))+parseAndGetInfoAt doc pos@(Position l _) = do+  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 _ -> return Nothing+    Nothing -> return Nothing++syntaxGetNodeAt :: Position -> Syntax -> Maybe LocTerm+syntaxGetNodeAt p (Command c@(Located _ (ShowCommand t))) = if isContained p c then getNodeAt p t else Nothing+syntaxGetNodeAt p (Command c@(Located _ (TypeCommand t))) = if isContained p c then getNodeAt p t else Nothing+syntaxGetNodeAt _ (Command _) = Nothing+syntaxGetNodeAt p (Exec t) = getNodeAt p t+syntaxGetNodeAt p (Def ldef@(Located _ (Definition _ _ t))) = if isContained p ldef then getNodeAt p t else Nothing+syntaxGetNodeAt p (DynDef ldef@(Located _ (DynamicDefinition _ t))) = if isContained p ldef then getNodeAt p t else Nothing+syntaxGetNodeAt p (MacroDef ldef@(Located _ (MacroDefinition _ t))) = if isContained p ldef then getNodeAt p t else Nothing++getNodeAt :: Position -> LocTerm -> Maybe LocTerm+getNodeAt p lt =+  if isContained p lt+    then+      ( case lt of+          t@(Located _ (TVar _)) -> Just t+          t@(Located _ (TNum _)) -> Just t+          t@(Located _ (TText _)) -> Just t+          t@(Located _ TRest) -> Just t+          (Located _ (TInfix t1 op t2)) -> if isContained p op then Just (fmap TVar op) else findWithPos p [t1, t2] >>= getNodeAt p+          (Located _ (TSectionR op t)) -> if isContained p op then Just (fmap TVar op) else getNodeAt p t+          (Located _ (TSectionL t op)) -> if isContained p op then Just (fmap TVar op) else getNodeAt p t+          (Located _ t) -> findWithPos p (subterms t) >>= getNodeAt p+      )+    else Nothing++infoMarkdown :: T.Text -> CI (Maybe T.Text)+infoMarkdown n = do+  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+    Nothing -> return Nothing++wrapCodeBlock :: T.Text -> T.Text+wrapCodeBlock t = "``` haskell\n" <> t <> "\n```"
+ src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs view
@@ -0,0 +1,75 @@+module Zwirn.Language.LSP.InlayHints where++import Control.Concurrent (readMVar)+import Control.Monad.RWS (gets, liftIO)+import qualified Data.Map as Map+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.Location (Located (..), Position (..), RealSrcLoc (..), SrcLoc (..))+import Zwirn.Stream.Target (Targeted (..))+import Zwirn.Stream.Types (Identifier (..), PlayMap, PlayState (..), Stream (..))++data Hint+  = Hint+  { hPos :: Position,+    hContent :: Text,+    hDescription :: Text+  }+  deriving (Show)++getHints :: Text -> CI [Hint]+getHints doc = do+  blocks <- runBlocks 0 doc+  ss <- concat <$> catchMany (map parseBlock blocks)+  sh <- getStreamHints ss+  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+getStreamHints :: [Syntax] -> CI [Hint]+getStreamHints ss = do+  pm <- gets (sPlayMap . tStream) >>= liftIO . readMVar+  let chans = map findStreamPattern ss+  return $ mapMaybe (resolvePlayState pm) chans++-- | returns the channel key and a positon one line above it+findStreamPattern :: Syntax -> Maybe (Identifier, Position)+findStreamPattern (Exec (Located (SrcLoc (RealSrcLoc _ ln ch _ _)) (TInfix (Located _ (TNum chan)) (Located _ "($:)") _))) = if ln <= 1 then Nothing else Just (NumID (read $ unpack chan), Position (ln - 1) ch)+findStreamPattern (Exec (Located (SrcLoc (RealSrcLoc _ ln ch _ _)) (TInfix (Located _ (TText chan)) (Located _ "($:)") _))) = if ln <= 1 then Nothing else Just (TextID $ stripText chan, Position (ln - 1) ch)+  where+    stripText = T.filter (/= '\"')+findStreamPattern _ = Nothing++lookupPlayState :: Identifier -> PlayMap -> Maybe PlayState+lookupPlayState key pm = (\(Targeted _ (x, _, _)) -> x) <$> Map.lookup key pm++resolvePlayState :: PlayMap -> Maybe (Identifier, Position) -> Maybe Hint+resolvePlayState pm mx+  | noSolo pm = do+      (key, pos) <- mx+      ps <- lookupPlayState key pm+      case ps of+        Solo -> return $ Hint pos "(solo)" "stream hint"+        Mute -> return $ Hint pos "(muted)" "stream hint"+        Normal -> return $ Hint pos "(playing)" "stream hint"+  | otherwise = do+      (key, pos) <- mx+      ps <- lookupPlayState key pm+      case ps of+        Solo -> return $ Hint pos "(solo)" "stream hint"+        Mute -> return $ Hint pos "(muted)" "stream hint"+        Normal -> return $ Hint pos "(not soloed)" "stream hint"++-- | inlay hints underneath commands to display their output+getCommandHints :: [Syntax] -> CI [Hint]+getCommandHints ss = catMaybes <$> filterErrors (map commandHint ss)++commandHint :: Syntax -> CI (Maybe Hint)+commandHint (Command (Located (SrcLoc (RealSrcLoc _ _ _ ln ch)) x)) = do+  out <- runCommand x+  case out of+    OutMessage ms -> return $ Just $ Hint (Position ln (ch + 1)) ("\n" <> ms) "command hint"+    _ -> return Nothing+commandHint _ = return Nothing
+ src/zwirn-lang/Zwirn/Language/Lexer.x view
@@ -0,0 +1,383 @@+{+{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Zwirn.Language.Lexer+  ( -- * Invoking Alex+    Alex+  , AlexPosn (..)+  , alexGetInput+  , alexError+  , runAlex+  , alexMonadScan++  , Lexeme+  , Token (..)+  , scanMany+  , increaseChoice+  , setSrcPath+  , getSrcPath+  , setInitialLineNum+  , lineLexer+  , typeLexer+  ) where++{-+    Lexer.hs - lexer for zwirn, code adapted from+    https://serokell.io/blog/lexing-with-alex+    Copyright (C) 2025, 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.  IfTok not, see <http://www.gnu.org/licenses/>.+-}++import           Data.Text (Text)+import qualified Data.Text as Text+import Control.Monad (when)+import Zwirn.Language.Location++}++%wrapper "monadUserState-strict-text"++$digit = [0-9]+$alphasmall = [a-z]+$alphabig = [A-Z]+$alpha = [a-zA-Z]++@id = ($alphasmall) ($alpha | $digit | \_ )*+@singles = ("&" | "$" | "?" | "#" | "." | "^" | ":")+@otherops = ("|" | "=" | "~" | "<" | ">" | "%" | "!")+@specialop = ("*" | "/" | "'" | "+" | "-")+@op = ((@singles (@singles | @otherops | @specialop)*) | ((@otherops | @specialop) (@singles | @otherops | @specialop)+))+@num = ("-")? ($digit)+ ("." ($digit)+)?+@path = $white ($alpha | "/" | ".")++@flag = $alphabig $alpha*++tokens :-++<0> $white+ ;+++-- Single Line Comments+<line> "--" .* (\n?) ;++<line> (.+ (\n?) | \n)             { mkLine }+++<ty> $white+ ;+<ty> $alpha+ "." ;+<ty> "=>"                          { tok TypeContextTok }+<ty> "->"                          { tok ArrowTok }+<ty> "("                           { tok LParTok }+<ty> ")"                           { tok RParTok }+<ty> ","                           { tok CommaTok }+<ty> "Text"                        { tok TextTypeTok }+<ty> "Number"                      { tok NumberTypeTok }+<ty> "Map"                         { tok MapTypeTok }+<ty> "Action"                      { tok ActionTypeTok }+<ty> @id                           { tokText VarTypeTok }+<ty> [A-Z] $alphasmall+            { tokText TypeClassTok }+<ty> @id                           { tokText IdentifierTok }+<ty> @op                           { tokText OperatorTok }+<ty> @specialop                    { tokText SpecialOperatorTok }++-- Single Line Comments+<0>  "--" .* (\n?) ;++-- Macro++<0> "!"($alphasmall)+ { tokText (\t -> MacroTok $ Text.drop 1 t)}++-- Repeat+<0> "!"               { tok RepeatTok }+<0> "!"($digit+)      { tokText (\t -> RepeatNumberTok $ Text.drop 1 t) }++-- Parenthesis+<0> "("     { tok LParTok }+<0> ")"     { tok RParTok }++-- Sequences+<0> "["     { tok LBrackTok }+<0> "]"     { tok RBrackTok }++-- Stacks+<0> ","     { tok CommaTok }++-- Choice+<0> "|"     { tok ChoiceTok }++-- Enum+<0> ".."    { tok EnumTok }++-- Polyrhythm+<0> "%"     { tok PolyTok }++<0> "{"     { tok LBracesTok }+<0> "}"     { tok RBracesTok }++-- Lambda+<0> "\"     { tok LambdaTok }+<0> "->"    { tok ArrowTok }++-- Definitions+<0> "="                               { tok DefineTok }+<0> "<-"                              { tok DynamicDefineTok }++-- Commands+<0> ":t"                              { tok TypeCommandTok }+<0> ":show"                           { tok ShowCommandTok }+<0> ":config"                         { tok ShowConfigCommandTok }+<0> ":resetconfig"                    { tok ResetShowConfigCommandTok }+<0> ":info"                           { tok InfoCommandTok }+<0> ":reset"                          { tok ResetEnvCommandTok }+<0> ":set"                            { tok SetCommandTok }+<0> ":status"                         { tok StatusCommandTok }+<0> ":env"                            { tok EnvCommandTok }+<0> (":load") @path                   { tokText (\t -> LoadCommandTok $ Text.drop 6 t) }++-- Keywords+<0> if      { tok IfTok }+<0> then    { tok ThenTok }+<0> else    { tok ElseTok }++-- Identifiers+<0> @id             { tokText IdentifierTok }++-- Constants+<0> @num            { tokText NumberTok }+<0> \"[^\"]*\"      { tokText TextTok }+<0> "~"             { tok RestTok }+<0> "_"             { tok UnderscoreTok }++-- Compiler Flags++<0> @flag           { tokText CompilerFlagTok }++-- Operators+<0> @op             { tokText OperatorTok }+<0> @specialop      { tokText SpecialOperatorTok }++-- Alternations+<0> "<"     { tok LAngleTok }+<0> ">"     { tok RAngleTok }++{+data AlexUserState = AlexUserState+  { nestLevel :: Int+  , choiceNum :: Int+  , srcPath :: Text+  }++alexInitUserState :: AlexUserState+alexInitUserState = AlexUserState { nestLevel = 0, choiceNum = 0, srcPath = Text.empty}++get :: Alex AlexUserState+get = Alex $ \s -> Right (s, alex_ust s)++put :: AlexUserState -> Alex ()+put s' = Alex $ \s -> Right (s{alex_ust = s'}, ())++modify :: (AlexUserState -> AlexUserState) -> Alex ()+modify f = Alex $ \s -> Right (s{alex_ust = f (alex_ust s)}, ())++alexEOF :: Alex Lexeme+alexEOF = pure $ Located NoLoc EOF++type Lexeme = Located Token++data Token+  -- Identifiers+  = IdentifierTok Text+  -- Constants+  | TextTok Text+  | NumberTok Text+  | MacroTok Text+  | RestTok+  | UnderscoreTok+  -- Operators+  | OperatorTok Text+  | SpecialOperatorTok Text+  -- Repeat+  | RepeatTok+  | RepeatNumberTok Text+  -- Parenthesis+  | LParTok+  | RParTok+  -- Sequences+  | LBrackTok+  | RBrackTok+  -- Stacks+  | CommaTok+  -- Alternations+  | LAngleTok+  | RAngleTok+  -- Choice+  | ChoiceTok+  -- Polyrhythm+  | PolyTok+  | LBracesTok+  | RBracesTok+  -- LambdaTok+  | LambdaTok+  | ArrowTok+  -- If Then Else+  | IfTok+  | ThenTok+  | ElseTok+  -- Enum+  | EnumTok+  -- Definitions+  | DefineTok+  | DynamicDefineTok+  -- Commands+  | TypeCommandTok+  | ShowCommandTok+  | ShowConfigCommandTok+  | ResetShowConfigCommandTok+  | LoadCommandTok Text+  | InfoCommandTok+  | ResetEnvCommandTok+  | SetCommandTok+  | StatusCommandTok+  | EnvCommandTok+  | CompilerFlagTok Text+  -- Line & Block Tokens+  | LineTok Text+  | BlockSepTok+  -- Type Tokens+  | TypeContextTok+  | TextTypeTok+  | NumberTypeTok+  | MapTypeTok+  | ActionTypeTok+  | VarTypeTok Text+  | TypeClassTok Text+  -- EOF+  | EOF+  deriving (Eq)++instance Show Token where+ show (IdentifierTok s) = show s+ show (TextTok s) = show s+ show (NumberTok d) = show d+ show (MacroTok d) = show d+ show RestTok = quoted "~"+ show UnderscoreTok = quoted "_"+ show (OperatorTok o) = show o+ show (SpecialOperatorTok o) = show o+ show RepeatTok = quoted "!"+ show (RepeatNumberTok x) = quoted "!" ++ show x+ show LParTok = quoted "("+ show RParTok = quoted ")"+ show LBrackTok = quoted "["+ show RBrackTok = quoted "]"+ show CommaTok = quoted ","+ show LAngleTok = quoted "<"+ show RAngleTok = quoted ">"+ show ChoiceTok = quoted "|"+ show PolyTok = quoted "%"+ show LBracesTok = quoted "{"+ show RBracesTok = quoted "}"+ show LambdaTok = quoted "\\"+ show ArrowTok = quoted "->"+ show IfTok = quoted "if"+ show ThenTok = quoted "then"+ show ElseTok = quoted "else"+ show EnumTok = quoted ".."+ show DynamicDefineTok = quoted "<-"+ show TypeCommandTok = quoted ":t"+ show ShowCommandTok = quoted ":show"+ show ShowConfigCommandTok = quoted ":config"+ show ResetShowConfigCommandTok = quoted ":resetconfig"+ show DefineTok = quoted "="+ show (LoadCommandTok x) = ":load " <> show x+ show InfoCommandTok = quoted ":info"+ show ResetEnvCommandTok = quoted ":reset"+ show SetCommandTok = quoted ":set"+ show StatusCommandTok = quoted ":status"+ show EnvCommandTok = quoted ":env"+ show (CompilerFlagTok x) = show x+ show (LineTok t) = "line " <> show t+ show BlockSepTok = "block"+ show TypeContextTok = "=>"+ show TextTypeTok = "Text"+ show NumberTypeTok = "Number"+ show MapTypeTok = "Map"+ show ActionTypeTok = "Action"+ show (VarTypeTok t) = show t+ show (TypeClassTok c) = show c+ show EOF = "end of file"++quoted :: String -> String+quoted s = "'" ++ s ++ "'"++mkSrcLoc :: AlexAction SrcLoc+mkSrcLoc (st@(AlexPn _ lst cst), _, _, str) len = do+                       let (AlexPn _ lnen cen) = Text.foldl' alexMove st $ Text.take len str+                       p <- getSrcPath+                       return $ SrcLoc $ RealSrcLoc p lst cst lnen cen++mkLine :: AlexAction Lexeme+mkLine inp@(_, _, _, str) len = case Text.all (\c -> elem c ("\n\t " :: String)) (Text.take len str) of+                            True -> tok BlockSepTok inp len+                            False -> do+                                loc <- mkSrcLoc inp len+                                return $ Located loc (LineTok (Text.take len str))++tok :: Token -> AlexAction Lexeme+tok ctor inp len = do+            loc <- mkSrcLoc inp len+            return $ Located loc ctor+++tokText :: (Text -> Token) -> AlexAction Lexeme+tokText f inp@(_, _, _, str) len = do+            loc <- mkSrcLoc inp len+            return $ Located loc (f $ Text.take len str)+++increaseChoice :: Alex Int+increaseChoice = do+  (AlexUserState c x e) <- get+  put $ AlexUserState c (x+1) e+  return x++getSrcPath :: Alex Text+getSrcPath = do+  (AlexUserState _ _ p) <- get+  return p++setSrcPath :: Text -> Alex ()+setSrcPath i = do+  (AlexUserState c x _) <- get+  put $ AlexUserState c x i++setInitialLineNum :: Int -> Alex ()+setInitialLineNum i = Alex alex+                    where alex s = Right (s {alex_pos = AlexPn x i c }, ())+                                 where AlexPn x _ c = alex_pos s++lineLexer :: Alex ()+lineLexer = alexSetStartCode line++typeLexer :: Alex ()+typeLexer = alexSetStartCode ty++scanMany :: Text -> Either String [Lexeme]+scanMany input = runAlex input go+  where+    go = do+      output <- lineLexer >> alexMonadScan+      if lValue output == EOF+        then pure [output]+        else ((output) :) <$> go+}
+ src/zwirn-lang/Zwirn/Language/Location.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveFunctor #-}++module Zwirn.Language.Location where++{-+    Location.hs - data types and functions for manipulating source locations+    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 Data.List (find)+import Data.Text (Text)++data RealSrcLoc+  = RealSrcLoc+  { rSrcFile :: !Text,+    rStartLine :: !Int,+    rStartChar :: !Int,+    rEndLine :: !Int,+    rEndChar :: !Int+  }+  deriving (Eq, Show)++data SrcLoc+  = SrcLoc !RealSrcLoc+  | NoLoc+  deriving (Eq, Show)++data Located a+  = Located {lLoc :: !SrcLoc, lValue :: a}+  deriving (Eq, Show, Functor)++data Position = Position Int Int+  deriving (Eq, Show)++instance Semigroup SrcLoc where+  (<>) (SrcLoc (RealSrcLoc p1 lst cst _ _)) (SrcLoc (RealSrcLoc p2 _ _ len cen)) =+    if p1 == p2+      then SrcLoc (RealSrcLoc p1 lst cst len cen)+      else NoLoc+  (<>) NoLoc r = r+  (<>) r NoLoc = r++instance Monoid SrcLoc where+  mempty = NoLoc++noLoc :: a -> Located a+noLoc = Located NoLoc++withLoc :: RealSrcLoc -> a -> Located a+withLoc rn = Located (SrcLoc rn)++mapLoc :: (SrcLoc -> SrcLoc) -> Located a -> Located a+mapLoc f (Located s x) = Located (f s) x++mergeLocs :: [SrcLoc] -> SrcLoc+mergeLocs [] = NoLoc+mergeLocs [x] = x+mergeLocs (x : ys) = x <> last ys++mergeManyWith :: ([Located a] -> b) -> [Located a] -> Located b+mergeManyWith f xs = Located (mergeLocs ls) b+  where+    b = f xs+    ls = map lLoc xs++mergeTwoWith :: (Located a -> Located a -> b) -> Located a -> Located a -> Located b+mergeTwoWith f a b = Located (lLoc a <> lLoc b) (f a b)++mergeThreeWith :: (Located a -> Located a -> Located a -> b) -> Located a -> Located a -> Located a -> Located b+mergeThreeWith f a b c = Located (lLoc a <> lLoc c) (f a b c)++(<->) :: Located a -> Located b -> SrcLoc+(<->) a b = lLoc a <> lLoc b++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++findWithPos :: Position -> [Located a] -> Maybe (Located a)+findWithPos p = find (isContained p)
+ src/zwirn-lang/Zwirn/Language/Macro.hs view
@@ -0,0 +1,100 @@+module Zwirn.Language.Macro where++import Control.Monad.State (StateT, lift, modify, runStateT)+import qualified Data.Map as Map+import qualified Data.Text as T+import Zwirn.Language.Location (Located (..), RealSrcLoc (..), SrcLoc (..))+import Zwirn.Language.Pretty (ppterm)+import Zwirn.Language.Syntax (LocTerm, Term (..))++type MacroMap = Map.Map T.Text LocTerm++-- represents the code edit that replaces the text at editPos with editText+data CodeEdit = CodeEdit+  { editPos :: RealSrcLoc,+    editText :: T.Text+  }+  deriving (Eq, Show)++-- a simple monad that accumulates code edits+type MacroMonad = StateT [CodeEdit] Maybe++defaultMacroMap :: MacroMap+defaultMacroMap = Map.fromList [("num", Located (SrcLoc (RealSrcLoc "internal" 0 0 0 1)) (TNum "1"))]++runMacros :: LocTerm -> MacroMap -> Maybe (LocTerm, [CodeEdit])+runMacros t mmap = runStateT (substituteMacros mmap t) []++substituteMacros :: MacroMap -> LocTerm -> MacroMonad LocTerm+substituteMacros _ t@(Located _ (TNum _)) = return t+substituteMacros _ t@(Located _ (TText _)) = return t+substituteMacros _ t@(Located _ (TVar _)) = return t+substituteMacros ms (Located (SrcLoc oldPos@(RealSrcLoc doc stln stch _ _)) (TMacro name)) = do+  (Located p m) <- lift $ Map.lookup name ms+  let replace = ppterm m+  case p of+    NoLoc -> lift Nothing+    SrcLoc (RealSrcLoc _ stln' _ enln' ench') -> do+      let newPos = RealSrcLoc doc stln stch (stln + (enln' - stln')) ench'+          edit = CodeEdit oldPos replace+      modify (edit :)+      return $ Located (SrcLoc newPos) m+substituteMacros _ t@(Located _ TRest) = return t+substituteMacros ms (Located p (TBracket t)) = do+  s <- substituteMacros ms t+  return $ Located p (TBracket s)+substituteMacros ms (Located p (TRepeat t i)) = do+  s <- substituteMacros ms t+  return $ Located p (TRepeat s i)+substituteMacros ms (Located p (TLambda x t)) = do+  s <- substituteMacros ms t+  return $ Located p (TLambda x s)+substituteMacros ms (Located p (TSectionL t x)) = do+  s <- substituteMacros ms t+  return $ Located p (TSectionL s x)+substituteMacros ms (Located p (TSectionR x t)) = do+  s <- substituteMacros ms t+  return $ Located p (TSectionR x s)+substituteMacros ms (Located p (TSeq ts)) = do+  ss <- mapM (substituteMacros ms) ts+  return $ Located p (TSeq ss)+substituteMacros ms (Located p (TStack ts)) = do+  ss <- mapM (substituteMacros ms) ts+  return $ Located p (TStack ss)+substituteMacros ms (Located p (TAlt ts)) = do+  ss <- mapM (substituteMacros ms) ts+  return $ Located p (TAlt ss)+substituteMacros ms (Located p (TChoice i ts)) = do+  ss <- mapM (substituteMacros ms) ts+  return $ Located p (TChoice i ss)+substituteMacros ms (Located p (TPoly t1 t2)) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  return $ Located p (TPoly s1 s2)+substituteMacros ms (Located p (TApp t1 t2)) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  return $ Located p (TApp s1 s2)+substituteMacros ms (Located p (TInfix t1 n t2)) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  return $ Located p (TInfix s1 n s2)+substituteMacros ms (Located p (TIfThenElse t1 t2 Nothing)) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  return $ Located p (TIfThenElse s1 s2 Nothing)+substituteMacros ms (Located p (TEnum k t1 t2)) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  return $ Located p (TEnum k s1 s2)+substituteMacros ms (Located p (TEnumThen k t1 t2 t3)) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  s3 <- substituteMacros ms t3+  return $ Located p (TEnumThen k s1 s2 s3)+substituteMacros ms (Located p (TIfThenElse t1 t2 (Just t3))) = do+  s1 <- substituteMacros ms t1+  s2 <- substituteMacros ms t2+  s3 <- substituteMacros ms t3+  return $ Located p (TIfThenElse s1 s2 (Just s3))+substituteMacros _ _ = lift Nothing
+ src/zwirn-lang/Zwirn/Language/Parser.y view
@@ -0,0 +1,400 @@+{+module Zwirn.Language.Parser+    ( parseSyntaxWithPos+    , parseSyntax+    , parseTermWithPos+    , parseTerm+    , parseBlocks+    , parseScheme+    ) where++import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.List.NonEmpty as NE+import Data.Maybe (fromJust)+import Data.Monoid (First (..))+import Data.List (intercalate, sortOn)++import qualified Zwirn.Language.Lexer as L+import Zwirn.Language.Syntax+import Zwirn.Language.TypeCheck.Types+import Zwirn.Language.TypeCheck.Infer+import Zwirn.Language.Block+import Zwirn.Language.Location++{-+    Parser.hs - parser for zwirn, code adapted from+    https://serokell.io/blog/parsing-with-happy+    Copyright (C) 2025, 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.  IfTok not, see <http://www.gnu.org/licenses/>.+-}+++}++%name pTerm term+%name pSyntax syntax+%name pBlocks blocks+%name pScheme scheme+%tokentype { L.Lexeme }+%errorhandlertype explist+%error { parseError }+%monad { L.Alex } { >>= } { pure }+%lexer { lexer } { Located _ L.EOF }+%expect 0++%token+  -- Keywords+  if              { Located _ L.IfTok }+  then            { Located _ L.ThenTok }+  else            { Located _ L.ElseTok }+  -- IdentifierToks+  identifier      { Located _ (L.IdentifierTok _) }+  -- OperatorToks+  operator        { Located _ (L.OperatorTok _) }+  specop          { Located _ (L.SpecialOperatorTok _) }+  -- Constants+  string          { Located _ (L.TextTok _) }+  number          { Located _ (L.NumberTok _) }+  macro           { Located _ (L.MacroTok _) }+  flag            { Located _ (L.CompilerFlagTok _) }+  line            { Located _ (L.LineTok _) }+  bsep            { Located _ (L.BlockSepTok) }+  '~'             { Located _ L.RestTok }+  '_'             { Located _ L.UnderscoreTok }+  -- Repeat+  '!'             { Located _ L.RepeatTok }+  repnum          { Located _ (L.RepeatNumberTok _) }+  -- Parenthesis+  '('             { Located _ L.LParTok }+  ')'             { Located _ L.RParTok }+  -- Sequences+  '['             { Located _ L.LBrackTok }+  ']'             { Located _ L.RBrackTok }+  -- Stacks+  ','             { Located _ L.CommaTok }+  -- Alternations+  '<'             { Located _ L.LAngleTok }+  '>'             { Located _ L.RAngleTok }+  -- Choice+  '|'             { Located _ L.ChoiceTok }+  -- EnumTok+  '..'            { Located _ L.EnumTok }+  -- PolyTokrhythm+  '%'             { Located _ L.PolyTok }+  -- LambdaTok+  '\\'            { Located _ L.LambdaTok }+  '->'            { Located _ L.ArrowTok }+  -- Definitions+  '='             { Located _ L.DefineTok }+  '<-'            { Located _ L.DynamicDefineTok }+  -- Actions+  ':t'            { Located _ L.TypeCommandTok }+  ':show'         { Located _ L.ShowCommandTok }+  ':config'       { Located _ L.ShowConfigCommandTok }+  ':resetconfig'  { Located _ L.ResetShowConfigCommandTok }+  ':load'         { Located _ (L.LoadCommandTok _ ) }+  ':info'         { Located _ L.InfoCommandTok }+  ':reset'        { Located _ L.ResetEnvCommandTok }+  ':set'          { Located _ L.SetCommandTok }+  ':status'       { Located _ L.StatusCommandTok }+  ':env'          { Located _ L.EnvCommandTok }+  -- Type Tokens+  '=>'            { Located _ L.TypeContextTok }+  textT           { Located _ L.TextTypeTok }+  numT            { Located _ L.NumberTypeTok }+  mapT            { Located _ L.MapTypeTok }+  actionT         { Located _ L.ActionTypeTok }+  varT            { Located _ (L.VarTypeTok _) }+  classT          { Located _ (L.TypeClassTok _) }++%%++-------------------------------------------------------------+------------------------- utilities -------------------------+-------------------------------------------------------------++optional(p)+  :                                             { Nothing }+  | p                                           { Just $1 }++many_rev(p)+  :                                             { [] }+  | many_rev(p) p                               { $2 : $1 }++many(p)+  : many_rev(p)                                 { reverse $1 }++some_rev(p)+  : p                                           { [$1] }+  | some_rev(p) p                               { $2 : $1 }++some(p)+  : some_rev(p)                                 { reverse $1 }++sepBy_rev(p, sep)+  : p                                           { [$1] }+  | sepBy_rev(p, sep) sep p                     { $3 : $1 }++sepBy(p, sep)+  : sepBy_rev(p, sep)                           { reverse $1 }++sepBy_rev2(p, sep)+  : p sep p                                     { [$3, $1] }+  | sepBy_rev2(p, sep) sep p                    { $3 : $1 }++sepBy2(p, sep)+  : sepBy_rev2(p, sep)                          { reverse $1 }++-------------------------------------------------------------+----------------------- parsing terms -----------------------+-------------------------------------------------------------++atom :: { LocTerm }+  : identifier                                  { (mkAtom TVar) $1 }+  | '(' operator  ')'                           { (mkAtom TVar) $2 }+  | '(' specop  ')'                             { (mkAtom TVar) $2 }+  | number                                      { (mkAtom TNum) $1 }+  | string                                      { (mkAtom TText) $1 }+  | macro                                       { (mkAtom TMacro) $1 }+  | '~'                                         { Located (lLoc $1) TRest }++simpleseq :: { [LocTerm] }+  : infix                                %shift { [$1] }+  | infix simpleseq                             { $1:$2 }++seq :: { LocTerm }+  : simpleseq                                   { mergeManyWith TSeq $1 }+  | infix '..' infix                            { Located ($1 <-> $3) $ (TEnum Run) $1 $3 }+  | infix infix '..' infix                      { Located ($1 <-> $4) $ (TEnumThen Run) $1 $2 $4 }++sequence :: { LocTerm }+  :  '[' seq ']'                                { $2 }+  |  '[' ']'                                    { Located ($1 <-> $2) TRest }++choice :: { LocTerm }+  : '[' sepBy2(simpleseq, '|') ']'                             { % L.increaseChoice >>= \x -> return $ Located ($1 <-> $3) (TChoice x (map (mergeManyWith TSeq) $2)) }+  | '[' simpleseq '|' '..' simpleseq ']'                       { Located ($1 <-> $6) $ (TEnum Choice) (mergeManyWith TSeq $2) (mergeManyWith TSeq $5) }+  | '[' simpleseq '|' simpleseq '..' simpleseq ']'             { Located ($1 <-> $7) $ (TEnumThen Choice) (mergeManyWith TSeq $2) (mergeManyWith TSeq $4) (mergeManyWith TSeq $6) }++lambda :: { LocTerm }+  : '\\' some(identifier) '->' term      %shift { Located ($1 <-> $4) $ TLambda (map unTok $2) $4 }++polyrhythm :: { LocTerm }+  : simple '%' simple                    %shift { Located ($1 <-> $3) $ TPoly $1 $3 }++repeat :: { LocTerm }+  : simple repnum                               { Located ($1 <-> $2) $ TRepeat $1 (Just $ read $ Text.unpack $ unTok $2) }+  | simple '!'                                  { Located ($1 <-> $2) $ TRepeat $1 Nothing }++stack :: { LocTerm }+  : '[' sepBy2(simpleseq, ',') ']'                   { Located ($1 <-> $3) $ TStack (map (mergeManyWith TSeq) $2) }+  | '[' simpleseq ',' '..' simpleseq ']'             { Located ($1 <-> $6) $ TEnum Cord (mergeManyWith TSeq $2) (mergeManyWith TSeq $5) }+  | '[' simpleseq ',' simpleseq '..' simpleseq ']'   { Located ($1 <-> $7) $ TEnumThen Cord (mergeManyWith TSeq $2) (mergeManyWith TSeq $4) (mergeManyWith TSeq $6) }++alt :: { LocTerm }+  : simpleseq                                   { mergeManyWith TAlt $1 }+  | infix '..' infix                            { Located ($1 <-> $3) $ (TEnum Alt) $1 $3 }+  | infix infix '..' infix                      { Located ($1 <-> $4) $ (TEnumThen Alt) $1 $2 $4 }++alternation :: { LocTerm }+  : '<' alt '>'                                { mapLoc (const ($1 <-> $3)) $2 }++bracket :: { LocTerm }+  : '(' term ')'                                { Located ($1 <-> $3) $ TBracket $2 }++simple :: { LocTerm }+  : atom                                        { $1 }+  | alternation                                 { $1 }+  | sequence                                    { $1 }+  | choice                                      { $1 }+  | stack                                       { $1 }+  | lambda                                      { $1 }+  | polyrhythm                                  { $1 }+  | repeat                                      { $1 }+  | bracket                                     { $1 }++-- special operators are left-associative+specialinfix :: { LocTerm }+  : specialinfix specop simple           %shift { mapLoc (const $ $1 <-> $3) $ mkAtom (\t -> TInfix $1 (Located (lLoc $2) t) $3) $2 }+  | simple                               %shift { $1 }++-- all other operators are assumed to be right-associative, AST rotation will fix it+-- this definition is for use inside of sequences+infix :: { LocTerm }+  : specialinfix operator infix          %shift { mapLoc (const $ $1 <-> $3) $ mkAtom (\t -> TInfix $1 (Located (lLoc $2) t) $3) $2 }+  | specialinfix                         %shift { $1 }++-- application is left-associative, binds stronger than operators+-- outside of sequences+app :: { LocTerm }+  : app specialinfix                     %shift { Located ($1 <-> $2) $ TApp $1 $2 }+  | specialinfix                         %shift { $1 }++sectionR :: { LocTerm }+  : operator app                         %shift { mapLoc (const $ $1 <-> $2) $ mkAtom (\t -> TSectionR (Located (lLoc $1) t) $2) $1 }++sectionL :: { LocTerm }+  : app operator                         %shift { mapLoc (const $ $1 <-> $2) $ mkAtom (\t -> TSectionL $1 (Located (lLoc $2) t)) $2 }++conditional :: { LocTerm }+  : if term then term                    %shift { Located ($1 <-> $4) $ TIfThenElse $2 $4 Nothing }+  | if term then term else term                 { Located ($1 <-> $6) $ TIfThenElse $2 $4 (Just $6) }++-- operators outside of sequences have the weakest binding+term :: { LocTerm }+  : app operator term                    %shift { mapLoc (const $ $1 <-> $3) $ mkAtom (\t -> TInfix $1 (Located (lLoc $2) t) $3) $2 }+  | app                                  %shift { $1 }+  | sectionR                             %shift { $1 }+  | sectionL                             %shift { $1 }+  | conditional                                 { $1 }++-----------------------------------------------------------------+---------------------- parsing full syntax ----------------------+-----------------------------------------------------------------++def :: { Located Definition }+  : identifier many(identifier) '=' term        { Located ($1 <-> $4) $ Definition (unTok $1) (map unTok $2) $4 }+  | '(' operator  ')' many(identifier) '=' term { Located ($1 <-> $6) $ Definition (unTok $2) (map unTok $4) $6 }++dyndef :: { Located DynamicDefinition }+  : identifier '<-' term                        { Located ($1 <-> $3) $ DynamicDefinition (unTok $1) $3 }++macrodef :: { Located MacroDefinition }+  : macro '=' term                              { Located ($1 <-> $3) $ MacroDefinition (unTok $1) $3 }++command :: { Located Command }+  : ':config'                                   { Located (lLoc $1) ShowConfigPathCommand }+  | ':resetconfig'                              { Located (lLoc $1) ResetConfigCommand }+  | ':reset'                                    { Located (lLoc $1) ResetEnvCommand }+  | ':status'                                   { Located (lLoc $1) StatusCommand }+  | ':env'                                      { Located (lLoc $1) EnvCommand }+  | ':load'                                     { Located (lLoc $1) $ LoadCommand $ unTok $1 }+  | ':set' flag                                 { Located ($1 <-> $2) $ SetCommand (unTok $2) }+  | ':info' identifier                          { Located ($1 <-> $2) $ InfoCommand $ unTok $2 }+  | ':t' term                                   { Located ($1 <-> $2) $ TypeCommand $2 }+  | ':show' term                                { Located ($1 <-> $2) $ ShowCommand $2 }++syntax :: { Syntax }+  : dyndef                                      { DynDef $1 }+  | def                                         { Def $1 }+  | macrodef                                    { MacroDef $1 }+  | command                                     { Command $1 }++-------------------------------------------------------------+----------------------- parsing blocks ----------------------+-------------------------------------------------------------++block :: { Block }+  : some(line)                                     { toBlock $1 }++blocksrecrev :: { [Block] }+  : blocksrecrev some(bsep) block                  { $3:$1 }+  | block                                          { [$1] }++blocks :: { [Block] }+  : some(bsep) blocksrecrev some(bsep)             { reverse $2 }+  | some(bsep) blocksrecrev                        { reverse $2 }+  | blocksrecrev some(bsep)                        { reverse $1 }+  | blocksrecrev                                   { reverse $1 }++-------------------------------------------------------------+----------------------- parsing types -----------------------+-------------------------------------------------------------++atomType :: { Type }+  : textT                                       { TypeCon "Text" }+  | numT                                        { TypeCon "Number" }+  | mapT                                        { TypeCon "Map" }+  | actionT                                     { TypeCon "Action" }+  | varT                                        { TypeVar (unTok $1) }++fullType :: { Type }+  : atomType                                    { $1 }+  | fullType '->' fullType               %shift { TypeArr (noLoc $1) (noLoc $3) }+  | '(' fullType ')'                            { $2 }++predicate :: { Predicate }+  : classT varT                                 { IsIn (unTok $1) (TypeVar (unTok $2)) }++predicates :: { [Predicate] }+  : predicate '=>'                              { [$1] }+  |                                             { [] }++scheme :: { Scheme }+  : predicates fullType                  %shift { generalize $1 [] (noLoc $2) }+++{++parseError :: (L.Lexeme, [String]) -> L.Alex a+parseError (Located _ t, poss) = do+  (L.AlexPn _ ln column, _, _, _) <- L.alexGetInput+  L.alexError $ "Parse error at line " <> show ln <> ", column " <> show column+                <> "\n\tunexpected " <> show t+                <> "\n\texpecting " <> (intercalate "," poss)++lexer :: (L.Lexeme -> L.Alex a) -> L.Alex a+lexer = (=<< L.alexMonadScan)++unTok :: L.Lexeme -> Text+unTok (Located  _ (L.IdentifierTok x)) = x+unTok (Located  _  (L.NumberTok x)) = x+unTok (Located  _  (L.TextTok x))= x+unTok (Located  _  (L.MacroTok x))= x+unTok (Located  _  (L.OperatorTok x)) = "(" <> x <> ")"+unTok (Located  _  (L.SpecialOperatorTok x)) = "(" <> x <> ")"+unTok (Located  _  (L.LoadCommandTok x)) = x+unTok (Located  _  (L.LineTok x)) = x+unTok (Located  _  (L.VarTypeTok x)) = x+unTok (Located  _  (L.TypeClassTok x)) = x+unTok (Located  _  (L.RepeatNumberTok x)) = x+unTok (Located  _  (L.CompilerFlagTok x)) = x+unTok _ = error "can't untok"++mkAtom :: (Text -> Term) -> L.Lexeme -> LocTerm+mkAtom constr tok@(Located l _) = Located l (constr (unTok tok))++toBlock :: [L.Lexeme] -> Block+toBlock xs = Block ls+           where ls = case NE.nonEmpty xs of+                             Just ys -> structureLines $ NE.map (\r -> Line (getLn r) (getLn r) (unTok r)) ys+                             Nothing -> error "Can't happen"+                 getLn (Located (SrcLoc (RealSrcLoc _ l _ _ _)) _) = l+++parseSyntaxWithPos :: Int -> Text -> Text -> Either String Syntax+parseSyntaxWithPos ln srcp input = case parseTermWithPos ln srcp input of+                                              Left _ -> L.runAlex input (L.setSrcPath srcp >> L.setInitialLineNum ln >> pSyntax)+                                              Right s -> Right $ Exec s++parseSyntax :: Text -> Either String Syntax+parseSyntax input = case L.runAlex input pSyntax of+                          Left _ -> Exec <$> parseTerm input+                          Right s -> Right s++parseTermWithPos :: Int -> Text -> Text -> Either String LocTerm+parseTermWithPos ln srcp input = L.runAlex input (L.setSrcPath srcp >> L.setInitialLineNum ln >> pTerm)++parseTerm :: Text -> Either String LocTerm+parseTerm input = L.runAlex input pTerm++parseBlocks :: Int -> Text -> Either String [Block]+parseBlocks line input = L.runAlex input (L.lineLexer >> L.setInitialLineNum line >> pBlocks)++parseScheme :: Text -> Either String Scheme+parseScheme input = L.runAlex input (L.typeLexer >> pScheme)++}
+ src/zwirn-lang/Zwirn/Language/Pretty.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Zwirn.Language.Pretty where++{-+    Pretty.hs - prettyprinter for zwirn+    Copyright (C) 2025, 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 qualified Data.Text as T+import Prettyprinter+import Prettyprinter.Render.Text (renderStrict)+import Text.Read (readMaybe)+import Zwirn.Language.Location (Located (..), RealSrcLoc (..), SrcLoc (..), noLoc)+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++instance Pretty Term where+  pretty (TVar x) = pretty x+  pretty (TNum x) = case (readMaybe (T.unpack x) :: Maybe Int) of+    Just i -> pretty i+    Nothing -> pretty x+  pretty (TText x) = pretty x+  pretty (TMacro x) = "!" <> pretty x+  pretty (TBracket x) = parens $ pretty x+  pretty TRest = "~"+  pretty (TRepeat x Nothing) = pretty x <> "!"+  pretty (TRepeat x (Just i)) = pretty x <> sep (replicate i "!")+  pretty (TSeq [t]) = pretty t+  pretty (TSeq ts) = group $ brackets $ sep $ map pretty ts+  pretty (TStack ts) = alignedBetween (map pretty ts) lbracket rbracket comma+  pretty (TAlt ts) = group $ alignedBetween (map pretty ts) langle rangle space+  pretty (TChoice _ ts) = group $ alignedBetween (map pretty ts) lbracket rbracket pipe+  pretty (TPoly x y) = pretty x <> "%" <> pretty y+  pretty (TApp x y) = pretty x <+> pretty y+  pretty (TLambda vs x) = "\\" <> hcat (punctuate space $ map (pretty . T.unpack) vs) <+> "->" <+> pretty x+  pretty (TIfThenElse x y (Just z)) = "if" <+> pretty x <+> "then" <+> pretty y <+> "else" <+> pretty z+  pretty (TIfThenElse x y Nothing) = "if" <+> pretty x <+> "then" <+> pretty y+  pretty (TSectionL t n) = pretty t <+> pretty (unpackOp $ lValue n)+  pretty (TSectionR n t) = pretty (unpackOp $ lValue n) <+> pretty t+  pretty (TEnum Run x y) = brackets (pretty x <+> ".." <+> pretty y)+  pretty (TEnumThen Run x y z) = brackets (pretty x <+> pretty y <+> ".." <+> pretty z)+  pretty (TEnum Cord x y) = brackets (pretty x <+> ", .." <+> pretty y)+  pretty (TEnumThen Cord x y z) = brackets (pretty x <> comma <+> pretty y <+> ".." <+> pretty z)+  pretty (TEnum Choice x y) = brackets (pretty x <+> "| .." <+> pretty y)+  pretty (TEnumThen Choice x y z) = brackets (pretty x <+> pipe <+> pretty y <+> ".." <+> pretty z)+  pretty (TEnum Alt x y) = angles (pretty x <+> ".." <+> pretty y)+  pretty (TEnumThen Alt x y z) = angles (pretty x <+> pretty y <+> ".." <+> pretty z)+  pretty inf@(TInfix {}) = startThenAlign (pretty x) (map (\(op, y) -> pretty (unpackOp $ lValue op) <+> pretty y) xs)+    where+      (x, xs) = infixChain (noLoc inf)++alignedBetween :: [Doc a] -> Doc a -> Doc a -> Doc a -> Doc a+alignedBetween [] _ _ _ = mempty+alignedBetween (x : xs) l r s = align $ vcat $ (l <> x) : map (s <>) xs ++ [r]++startThenAlign :: Doc ann -> [Doc ann] -> Doc ann+startThenAlign x xs = x <+> align (vsep xs)++unpackOp :: T.Text -> String+unpackOp t = filter (\c -> c /= '(' && c /= ')') $ T.unpack t++infixChain :: LocTerm -> (LocTerm, [(LocVar, LocTerm)])+infixChain (Located _ (TInfix x op y)) = let (t, cs) = infixChain y in (x, (op, t) : cs)+infixChain t = (t, [])++parensIf :: Bool -> Doc a -> Doc a+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+      isArrow (Located _ TypeArr {}) = True+      isArrow _ = False+  pretty (TypeVar a) = pretty a+  pretty (TypeCon a) = pretty a++instance Pretty Predicate where+  pretty (IsIn c t) = pretty c <+> pretty t++prettyPredicates :: [Predicate] -> Doc a+prettyPredicates ps = parensIf (length ps > 1) (hcat (punctuate comma (map pretty ps)))++instance (Pretty a) => Pretty (Qualified a) where+  pretty (Qual [] _ t) = pretty t+  pretty (Qual ps _ t) = prettyPredicates ps <+> "=>" <+> pretty t++instance Pretty Scheme where+  pretty (Forall _ t) = pretty t++instance Pretty SrcLoc where+  pretty NoLoc = "NoLoc"+  pretty (SrcLoc (RealSrcLoc _ lst cst len cen)) = parens $ vcat $ punctuate comma [pretty lst, pretty cst, pretty len, pretty cen]++renderDoc :: Doc a -> T.Text+renderDoc = renderStrict . layoutPretty defaultLayoutOptions++render :: (Pretty a) => a -> T.Text+render = renderDoc . pretty++pptype :: Type -> T.Text+pptype = render++ppscheme :: Scheme -> T.Text+ppscheme = render++ppterm :: Term -> T.Text+ppterm = render++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+  pretty (InfiniteType a b) = "Cannot construct the infinite type:" <+> pretty a <+> "=" <+> pretty b+  pretty (Ambigious cs) = vsep ["Cannot not match expected type: '" <> pretty a <> "' with actual type: '" <> pretty b <> "'\n" | Located _ (a, b) <- cs]+  pretty (UnboundVariable a) = "Variable not in scope:" <+> pretty a+  pretty (NoInstance (Located _ (IsIn c x))) = "No instance for" <+> pretty c <+> pretty x+  pretty NotImplemented = "Case not implemented in type-checker."++instance Pretty Command where+  pretty (TypeCommand t) = ":t" <+> pretty t+  pretty (ShowCommand t) = ":show" <+> pretty t+  pretty (InfoCommand t) = ":info" <+> pretty t+  pretty (SetCommand t) = ":set" <+> pretty t+  pretty (UnsetCommand t) = ":unset" <+> pretty t+  pretty (LoadCommand t) = ":load" <+> pretty t+  pretty ResetConfigCommand = ":resetconfig"+  pretty ShowConfigPathCommand = ":showconfig"+  pretty ResetEnvCommand = ":reset"+  pretty StatusCommand = ":status"+  pretty EnvCommand = ":env"++instance Pretty Definition where+  pretty (Definition x xs t) = pretty x <+> vsep (map pretty xs) <+> "=" <+> pretty t++instance Pretty DynamicDefinition where+  pretty (DynamicDefinition x t) = pretty x <+> "<-" <+> pretty t++instance Pretty MacroDefinition where+  pretty (MacroDefinition x t) = "!" <> pretty x <+> "=" <+> pretty t++instance Pretty Syntax where+  pretty (Exec t) = pretty t+  pretty (Def d) = pretty d+  pretty (DynDef d) = pretty d+  pretty (MacroDef d) = pretty d+  pretty (Command c) = pretty c
+ src/zwirn-lang/Zwirn/Language/Rotate.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Zwirn.Language.Rotate+  ( runRotate,+    runRotateUnsafe,+    RotationError (..),+  )+where++{-+    Rotate.hs - syntax tree rotation, code adapted from+    https://gist.github.com/heitor-lassarote/b20d6da0a9042d31e439befb8c236a4e+    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 Control.Monad.Except+import Control.Monad.Identity+import Zwirn.Language.Location+import Zwirn.Language.Simple+import Zwirn.Language.Syntax++ops :: [Declaration]+ops =+  [ ("(*)", Fixity LeftA 9),+    ("(/)", Fixity LeftA 9),+    ("(.)", Fixity RightA 9),+    ("(+)", Fixity LeftA 6),+    ("(-)", Fixity LeftA 6),+    ("($)", Fixity RightA 0),+    ("($:)", Fixity RightA 0),+    ("(&:)", Fixity RightA 0),+    ("($!)", Fixity RightA 0),+    ("(#!)", Fixity RightA 0),+    ("($|)", Fixity RightA 0),+    ("(|$)", Fixity RightA 0),+    ("(#)", Fixity RightA 3),+    ("(&)", Fixity RightA 2),+    ("(++)", Fixity RightA 5),+    -- arithmetic+    ("(|-)", Fixity LeftA 6),+    ("(-|)", Fixity LeftA 6),+    ("(|+)", Fixity LeftA 6),+    ("(+|)", Fixity LeftA 6),+    ("(|*)", Fixity LeftA 7),+    ("(*|)", Fixity LeftA 7),+    ("(//)", Fixity LeftA 7),+    ("(|/)", Fixity LeftA 7),+    ("(/|)", Fixity LeftA 7),+    -- ord+    ("(<=)", Fixity NonA 4),+    ("(>=)", Fixity NonA 4),+    ("(&&)", Fixity RightA 3),+    ("(||)", Fixity RightA 3),+    ("(==)", Fixity NonA 4)+  ]++defaultFixity :: Fixity+defaultFixity = Fixity LeftA 8++newtype RotationError = RotationError SrcLoc++instance Show RotationError where+  show (RotationError (SrcLoc p)) = "Could not resolve operator precedence at location " ++ show p+  show (RotationError NoLoc) = "Could not resolve operator precedence"++type Rotate a = ExceptT RotationError Identity a++-- | Describes which action the rotation algorithm should use.+data Rotation+  = -- | Fail due to the mixing of incompatible operators.+    Fail+  | -- | Keep the tree as it is.+    Keep+  | -- | Balance the tree to the left.+    Rotate++runRotate :: LocSimpleTerm -> Either RotationError LocSimpleTerm+runRotate t = runIdentity $ runExceptT $ rotate t++runRotateUnsafe :: LocSimpleTerm -> LocSimpleTerm+runRotateUnsafe t = case runRotate t of+  Left err -> error $ show err+  Right r -> r++-- | The Happy parser is written in a way so that it will always create a right-balanced AST.+-- We compare the operators and indicate how to rotate the tree.+shouldRotate :: Fixity -> Fixity -> Rotation+shouldRotate (Fixity a p) (Fixity a' p') = case compare p p' of+  LT -> Keep+  EQ -> case (a, a') of+    (LeftA, LeftA) -> Rotate+    (RightA, RightA) -> Keep+    (_, _) -> Fail+  GT -> Rotate++-- | Rebalances the tree to respect the associativity and precedence of the+-- parsed operators.++-- Not very efficient, but enough for demonstration purposes.+findOp :: LocVar -> Rotate Fixity+findOp (Located _ o) = case lookup o ops of+  Just d -> return d+  Nothing -> return defaultFixity++rotate :: LocSimpleTerm -> Rotate LocSimpleTerm+rotate (Located p1 (SInfix l op r)) = do+  -- Rotating the left side is unneeded since this grammar is very simple.+  -- This is because trees are always right-balanced and the left side is+  -- always an atom.+  lRotated <- rotate l+  rRotated <- rotate r+  case rRotated of+    (Located p2 (SInfix l' op' r')) -> do+      opDec <- findOp op+      opDec' <- findOp op'+      case shouldRotate opDec opDec' of+        Fail -> throwError (RotationError $ lLoc op)+        Keep -> return $ Located p1 $ SInfix lRotated op rRotated+        Rotate -> return $ Located p2 $ SInfix (Located p1 $ SInfix lRotated op l') op' r'+    _ -> return $ Located p1 $ SInfix lRotated op rRotated+rotate (Located p (SApp l r)) = do+  lRotated <- rotate l+  rRotated <- rotate r+  return $ Located p $ SApp lRotated rRotated+rotate (Located p e@(SVar _)) = return $ Located p e+rotate (Located p e@(SText _)) = return $ Located p e+rotate (Located p e@(SNum _)) = return $ Located p e+rotate (Located p SRest) = return $ Located p SRest+rotate (Located p (SSeq ts)) = fmap (Located p . SSeq) (mapM rotate ts)+rotate (Located p (SStack ts)) = fmap (Located p . SStack) (mapM rotate ts)+rotate (Located p (SChoice n ts)) = fmap (Located p . SChoice n) (mapM rotate ts)+rotate (Located p (SLambda vs t)) = Located p . SLambda vs <$> rotate t+rotate (Located p (SBracket t)) = fmap (Located p . SBracket) (rotate t)
+ src/zwirn-lang/Zwirn/Language/Simple.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}++module Zwirn.Language.Simple+  ( simplify,+    simplifyLoc,+    SimpleTerm (..),+    SimpleDef (..),+    LocSimpleTerm,+  )+where++{-+    Simple.hs - desugaring of the zwirn AST+    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 Data.Text as Text (Text, filter, pack)+import Zwirn.Language.Location+import Zwirn.Language.Syntax++type LocSimpleTerm = Located SimpleTerm++-- simple representation of patterns+data SimpleTerm+  = SVar !Var+  | SText !Text+  | SNum !Text+  | SRest+  | SSeq [LocSimpleTerm]+  | SStack [LocSimpleTerm]+  | SChoice Int [LocSimpleTerm]+  | SLambda Var LocSimpleTerm+  | SApp LocSimpleTerm LocSimpleTerm+  | SInfix LocSimpleTerm LocVar LocSimpleTerm+  | SBracket LocSimpleTerm+  deriving (Eq, Show)++data SimpleDef+  = LetS !Var LocSimpleTerm+  deriving (Eq, Show)++simplifyLoc :: LocTerm -> LocSimpleTerm+simplifyLoc (Located p t) = Located p (simplify t)++simplify :: Term -> SimpleTerm+simplify (TVar x) = SVar x+simplify (TText x) = SText $ stripText x+  where+    stripText = Text.filter (/= '\"')+simplify (TNum x) = SNum x+simplify TRest = SRest+simplify x@(TRepeat _ _) = SSeq $ map (fmap simplify) $ resolveRepeat (Located NoLoc x)+simplify (TSeq ts) = SSeq (map (fmap simplify) $ concatMap resolveRepeat ts)+simplify (TStack ts) = SStack (map (fmap simplify) ts)+simplify (TChoice i ts) = SChoice i (map (fmap simplify) ts)+simplify (TAlt ts) = SBracket $ noLoc $ SInfix (noLoc $ SSeq ss) (noLoc "(/)") (noLoc $ SNum (pack $ show $ length ss))+  where+    ss = map (fmap simplify) $ concatMap resolveRepeat ts+simplify (TPoly (Located _ (TSeq ts)) n) = SBracket $ noLoc $ SInfix (noLoc $ SInfix (noLoc $ SSeq ss) (noLoc "(/)") (noLoc $ SNum (pack $ show $ length ss))) (noLoc "(*)") (fmap simplify n)+  where+    ss = map (fmap simplify) $ concatMap resolveRepeat ts+simplify (TPoly x n) = SInfix (fmap simplify x) (noLoc "(*)") (fmap simplify n)+simplify (TLambda [] t) = simplify (lValue t)+simplify (TLambda (x : xs) t) = SLambda x (noLoc $ simplify $ TLambda xs t)+simplify (TIfThenElse x y (Just z)) = SApp (noLoc $ SApp (noLoc $ SApp (noLoc $ SVar "ifthen") (fmap simplify x)) (fmap simplify y)) (fmap simplify z)+simplify (TIfThenElse x y Nothing) = SApp (noLoc $ SApp (noLoc $ SVar "if") (fmap simplify x)) (fmap simplify y)+simplify (TApp x y) = SApp (fmap simplify x) (fmap simplify y)+simplify (TInfix x op y) = SInfix (fmap simplify x) op (fmap simplify y)+simplify (TSectionR op y) = SLambda "_x" (noLoc $ SInfix (noLoc $ SVar "_x") op (fmap simplify y))+simplify (TSectionL x op) = SLambda "_x" (noLoc $ SInfix (fmap simplify x) op (noLoc $ SVar "_x"))+simplify (TBracket x) = SBracket (fmap simplify x)+simplify (TEnum Run x y) = SApp (noLoc $ SApp (noLoc $ SVar "runFromTo") (fmap simplify x)) (fmap simplify y)+simplify (TEnumThen Run x y z) = SApp (noLoc $ SApp (noLoc $ SApp (noLoc $ SVar "runFromThenTo") (fmap simplify x)) (fmap simplify y)) (fmap simplify z)+simplify (TEnum Alt x y) = SApp (noLoc $ SApp (noLoc $ SVar "slowrunFromTo") (fmap simplify x)) (fmap simplify y)+simplify (TEnumThen Alt x y z) = SApp (noLoc $ SApp (noLoc $ SApp (noLoc $ SVar "slowrunFromThenTo") (fmap simplify x)) (fmap simplify y)) (fmap simplify z)+simplify (TEnum Cord x y) = SApp (noLoc $ SApp (noLoc $ SVar "cordFromTo") (fmap simplify x)) (fmap simplify y)+simplify (TEnumThen Cord x y z) = SApp (noLoc $ SApp (noLoc $ SApp (noLoc $ SVar "cordFromThenTo") (fmap simplify x)) (fmap simplify y)) (fmap simplify z)+simplify (TEnum Choice x y) = SApp (noLoc $ SApp (noLoc $ SVar "chooseFromTo") (fmap simplify x)) (fmap simplify y)+simplify (TEnumThen Choice x y z) = SApp (noLoc $ SApp (noLoc $ SApp (noLoc $ SVar "chooseFromThenTo") (fmap simplify x)) (fmap simplify y)) (fmap simplify z)+simplify _ = error "Found unsubstituted macro while desugaring!"++resolveRepeat :: LocTerm -> [LocTerm]+resolveRepeat t = case getTotalRepeat t of+  Located _ (TRepeat x (Just i)) -> replicate i x+  Located _ (TRepeat x Nothing) -> [x, x]+  x -> [x]++-- TODO : not completely right when Nothing followed by Just...+getRepeat :: (LocTerm, Int) -> LocTerm+getRepeat (Located _ (TRepeat x (Just j)), k) = getRepeat (x, j * k)+getRepeat (Located _ (TRepeat x Nothing), k) = getRepeat (x, k + 1)+getRepeat (x, j) = noLoc $ TRepeat x (Just j)++getTotalRepeat :: LocTerm -> LocTerm+getTotalRepeat (Located _ (TRepeat t (Just i))) = getRepeat (t, i)+getTotalRepeat (Located _ (TRepeat t Nothing)) = getRepeat (t, 2)+getTotalRepeat t = t
+ src/zwirn-lang/Zwirn/Language/Syntax.hs view
@@ -0,0 +1,156 @@+module Zwirn.Language.Syntax where++{-+    Syntax.hs - definition of the zwirn language,+    inspired by tidals mini-notation+    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 Data.Text (Text)+import Zwirn.Language.Location++type Var = Text++type LocVar = Located Var++data EnumKind = Cord | Choice | Run | Alt deriving (Eq, Show)++type LocTerm = Located Term++-- sugary representation of patterns+data Term+  = TVar !Var+  | TText !Text+  | TNum !Text+  | TMacro !Text+  | TRest+  | TBracket LocTerm+  | TSeq [LocTerm]+  | TStack [LocTerm]+  | TAlt [LocTerm]+  | TChoice !Int [LocTerm]+  | TPoly LocTerm LocTerm+  | TApp LocTerm LocTerm+  | TInfix LocTerm LocVar LocTerm+  | TSectionL LocTerm LocVar+  | TSectionR LocVar LocTerm+  | TLambda [Var] LocTerm+  | TIfThenElse LocTerm LocTerm (Maybe LocTerm)+  | TRepeat LocTerm (Maybe Int)+  | TEnum EnumKind LocTerm LocTerm+  | TEnumThen EnumKind LocTerm LocTerm LocTerm+  deriving (Eq, Show)++data Command+  = TypeCommand LocTerm+  | ShowCommand LocTerm+  | InfoCommand !Text+  | SetCommand !Text+  | UnsetCommand !Text+  | LoadCommand !Text+  | ResetConfigCommand+  | ShowConfigPathCommand+  | ResetEnvCommand+  | StatusCommand+  | EnvCommand+  deriving (Eq, Show)++data Definition = Definition !Text [Text] LocTerm+  deriving (Eq, Show)++data DynamicDefinition = DynamicDefinition !Text LocTerm+  deriving (Eq, Show)++data MacroDefinition = MacroDefinition !Text LocTerm+  deriving (Eq, Show)++data Syntax+  = Exec LocTerm+  | Def (Located Definition)+  | DynDef (Located DynamicDefinition)+  | MacroDef (Located MacroDefinition)+  | Command (Located Command)+  deriving (Eq, Show)++data Associativity+  = NonA+  | LeftA+  | RightA+  deriving (Eq, Show)++type Precedence = Int++data Fixity+  = Fixity Associativity !Precedence+  deriving (Eq, Show)++type Declaration = (Var, Fixity)++subterms :: Term -> [LocTerm]+subterms (TVar _) = []+subterms (TNum _) = []+subterms (TText _) = []+subterms (TMacro _) = []+subterms TRest = []+subterms (TBracket t) = [t]+subterms (TLambda _ t) = [t]+subterms (TRepeat t _) = [t]+subterms (TSeq ts) = ts+subterms (TStack ts) = ts+subterms (TAlt ts) = ts+subterms (TChoice _ ts) = ts+subterms (TPoly x y) = [x, y]+subterms (TApp x y) = [x, y]+subterms (TInfix x _ y) = [x, y]+subterms (TSectionR _ t) = [t]+subterms (TSectionL t _) = [t]+subterms (TEnum _ x y) = [x, y]+subterms (TEnumThen _ x y z) = [x, y, z]+subterms (TIfThenElse x y (Just z)) = [x, y, z]+subterms (TIfThenElse x y Nothing) = [x, y]++-- mapTerm :: (Position -> Text -> Term -> a) -> Term -> [a]+-- mapTerm f t@(TVar pos x) = [f pos x t]+-- mapTerm f t@(TNum pos x) = [f pos x t]+-- mapTerm f t@(TText pos x) = [f pos x t]+-- mapTerm f t@(TRest pos) = [f pos (pack "~") t]+-- mapTerm f (TSeq ts) = concatMap (mapTerm f) ts+-- mapTerm f (TAlt ts) = concatMap (mapTerm f) ts+-- mapTerm f (TStack ts) = concatMap (mapTerm f) ts+-- mapTerm f (TChoice _ ts) = concatMap (mapTerm f) ts+-- mapTerm f (TCase x (Just y) ts) = concatMap (mapTerm f) ([x, y] ++ map snd ts)+-- mapTerm f (TCase x Nothing ts) = concatMap (mapTerm f) (x : map snd ts)+-- mapTerm f (TRepeat t _) = mapTerm f t+-- mapTerm f (TLambda _ t) = mapTerm f t+-- mapTerm f (TBracket t) = mapTerm f t+-- mapTerm f t@(TInfix x n pos y) = [f pos n t] ++ mapTerm f x ++ mapTerm f y+-- mapTerm f t@(TSectionR n pos x) = f pos n t : mapTerm f x+-- mapTerm f t@(TSectionL x n pos) = f pos n t : mapTerm f x+-- mapTerm f (TPoly x y) = mapTerm f x ++ mapTerm f y+-- mapTerm f (TEnum _ x y) = mapTerm f x ++ mapTerm f y+-- mapTerm f (TEnumThen _ x y z) = mapTerm f x ++ mapTerm f y ++ mapTerm f z+-- mapTerm f (TIfThenElse x y (Just z)) = mapTerm f x ++ mapTerm f y ++ mapTerm f z+-- mapTerm f (TIfThenElse x y Nothing) = mapTerm f x ++ mapTerm f y+-- mapTerm f (TApp x y) = mapTerm f x ++ mapTerm f y++-- mapAction :: (Term -> a) -> Action -> Maybe a+-- mapAction f (StreamAction _ t) = Just $ f t+-- mapAction f (StreamSet _ t) = Just $ f t+-- mapAction f (StreamOnce t) = Just $ f t+-- mapAction f (Type t) = Just $ f t+-- mapAction f (Show t) = Just $ f t+-- mapAction f (Def (Let _ _ t)) = Just $ f t+-- mapAction _ _ = Nothing
+ src/zwirn-lang/Zwirn/Language/TypeCheck/Constraint.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Zwirn.Language.TypeCheck.Constraint+  ( Substitutable (..),+    Subst (..),+    TypeError (..),+    Constraint,+    runSolve,+    unifiable,+  )+where++{-+    Constraint.hs - unification constraint solver adapted from+    https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints+    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 Control.Monad.Except+import Control.Monad.Identity+import qualified Data.Map as Map+import qualified Data.Set as Set+import Zwirn.Language.Environment+import Zwirn.Language.Location+import Zwirn.Language.Syntax (LocVar)+import Zwirn.Language.TypeCheck.Types++data TypeError+  = UnificationFail (Located Constraint)+  | InfiniteType TypeVar LocType+  | UnboundVariable LocVar+  | Ambigious [Located Constraint]+  | NoInstance (Located Predicate)+  | NotImplemented+  deriving (Eq)++type Constraint = (Type, Type)++newtype Subst = Subst (Map.Map TypeVar Type)+  deriving (Eq, Show, Semigroup, Monoid)++type Unifier = (Subst, [Located Constraint])++-- | Constraint solver monad+type Solve a = ExceptT TypeError Identity a++class Substitutable a where+  apply :: Subst -> a -> a+  ftv :: a -> Set.Set TypeVar++instance Substitutable Type where+  apply _ (TypeCon a) = TypeCon a+  apply (Subst s) t@(TypeVar a) = Map.findWithDefault t a s+  apply s (t1 `TypeArr` t2) = apply s t1 `TypeArr` apply s t2++  ftv TypeCon {} = Set.empty+  ftv (TypeVar a) = Set.singleton a+  ftv (t1 `TypeArr` t2) = ftv t1 `Set.union` ftv t2++instance Substitutable Scheme where+  apply (Subst s) (Forall as t) = Forall as $ apply s' t+    where+      s' = Subst $ foldr Map.delete s as+  ftv (Forall as t) = ftv t `Set.difference` Set.fromList as++instance Substitutable Constraint where+  apply s (t1, t2) = (apply s t1, apply s t2)+  ftv (t1, t2) = ftv t1 `Set.union` ftv t2++instance Substitutable AnnotatedExpression where+  apply s (Annotated x sc d) = Annotated x (apply s sc) d+  ftv (Annotated _ s _) = ftv s++instance (Substitutable a) => Substitutable [a] where+  apply = map . apply+  ftv = foldr (Set.union . ftv) Set.empty++instance Substitutable InterpreterEnv where+  apply s (IEnv ty cl) = IEnv (Map.map (apply s) ty) (apply s cl)+  ftv (IEnv ty cl) = ftv (Map.elems ty) `Set.union` ftv cl++instance Substitutable Predicate where+  apply s (IsIn x t) = IsIn x (apply s t)+  ftv (IsIn _ t) = ftv t++instance (Substitutable t) => Substitutable (Qualified t) where+  apply s (Qual ps ds t) = Qual (apply s ps) ds (apply s t)+  ftv (Qual ps _ t) = ftv ps `Set.union` ftv t++instance (Substitutable t) => Substitutable (Located t) where+  apply s = fmap (apply s)+  ftv (Located _ t) = ftv t++-------------------------------------------------------------------------------+-- Constraint Solver+-------------------------------------------------------------------------------++unifiable :: (Type, Type) -> Bool+unifiable t = case runSolve [noLoc t] of+  Left _ -> False+  Right _ -> True++-- | The empty substitution+emptySubst :: Subst+emptySubst = mempty++-- | Compose substitutions+compose :: Subst -> Subst -> Subst+(Subst s1) `compose` (Subst s2) = Subst $ Map.map (apply (Subst s1)) s2 `Map.union` s1++-- | Run the constraint solver+runSolve :: [Located Constraint] -> Either TypeError Subst+runSolve cs = runIdentity $ runExceptT $ solver st+  where+    st = (emptySubst, cs)++unifies :: Located Constraint -> Solve Subst+unifies (Located _ (t1, t2)) | t1 == t2 = return emptySubst+unifies (Located _ (TypeVar v, t)) = v `bind` t+unifies (Located _ (t, TypeVar v)) = v `bind` t+unifies (Located p (TypeArr t1 t2, TypeArr t3 t4)) = do+  su1 <- unifies (Located (specifyLoc (lLoc t1) (lLoc t3) p) (lValue t1, lValue t3))+  su2 <- unifies (Located (specifyLoc (lLoc t2) (lLoc t4) p) (apply su1 (lValue t2), apply su1 (lValue t4)))+  return $ su2 `compose` su1+unifies c = throwError $ UnificationFail c++specifyLoc :: SrcLoc -> SrcLoc -> SrcLoc -> SrcLoc+specifyLoc NoLoc NoLoc p = p+specifyLoc (SrcLoc _) (SrcLoc _) p = p+specifyLoc NoLoc p _ = p+specifyLoc p NoLoc _ = p++-- Unification solver+solver :: Unifier -> Solve Subst+solver (su, cs) =+  case cs of+    [] -> return su+    (c : cs0) -> do+      su1 <- unifies c+      solver (su1 `compose` su, apply su1 cs0)++bind :: TypeVar -> Type -> Solve Subst+bind a t+  | isTypeVar a t = return emptySubst+  | occursCheck a t = throwError $ InfiniteType a (Located NoLoc t)+  | otherwise = return (Subst $ Map.singleton a t)++isTypeVar :: TypeVar -> Type -> Bool+isTypeVar x (TypeVar y) = x == y+isTypeVar _ _ = False++occursCheck :: (Substitutable a) => TypeVar -> a -> Bool+occursCheck a t = a `Set.member` ftv t
+ src/zwirn-lang/Zwirn/Language/TypeCheck/Infer.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE OverloadedStrings #-}++module Zwirn.Language.TypeCheck.Infer+  ( inferTerm,+    generalize,+  )+where++{-+    Infer.hs - type inference algorithm adapted from+    https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints+    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 Control.Monad (replicateM)+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.State+import Data.List (nub)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Text (Text, pack)+import Zwirn.Language.Environment+import Zwirn.Language.Location+import Zwirn.Language.Simple+import Zwirn.Language.Syntax (Var)+import Zwirn.Language.TypeCheck.Constraint+import Zwirn.Language.TypeCheck.Types++type Infer a =+  ReaderT+    InterpreterEnv+    ( StateT+        InferState+        ( Except+            TypeError+        )+    )+    a++newtype InferState = InferState {count :: Int}++initInfer :: InferState+initInfer = InferState {count = 0}++-------------------------------------------------------------------------------+-- Inference+-------------------------------------------------------------------------------++-- | Run the inference monad+runInfer :: InterpreterEnv -> Infer a -> Either TypeError a+runInfer env m = runExcept $ evalStateT (runReaderT m env) initInfer++-- | Solve for the toplevel type of an expression in a given environment+inferTerm :: InterpreterEnv -> LocSimpleTerm -> Either TypeError Scheme+inferTerm env ex = case runInfer env (infer ex) of+  Left err -> Left err+  Right (ty, ps, ds, cs) -> case runSolve cs of+    Left err -> Left err+    Right subst -> case runInfer env (filterAndCheck (apply subst ps) (apply subst ty)) of+      Left err -> Left err+      Right xs -> Right $ closeOver (map lValue xs) (map lValue ds) $ apply subst ty++-- | Canonicalize and return the polymorphic toplevel type.+closeOver :: [Predicate] -> [Dependency] -> LocType -> Scheme+closeOver ps ds t = normalize $ generalize ps ds t++-- | modified environment where x :: sc+inEnv :: (Name, Scheme) -> Infer a -> Infer a+inEnv (x, sc) m = do+  let scope = insertType x sc+  local scope m++-- | Lookup type in the environment+lookupEnv :: (SrcLoc, Var) -> Infer (Type, [Located Predicate], [Located Dependency])+lookupEnv (pos, x) = do+  env <- ask+  case lookupType x env of+    Nothing -> throwError $ UnboundVariable (Located pos x)+    Just s -> instantiate s pos++letters :: [Text]+letters = map pack $ [1 ..] >>= flip replicateM ['a' .. 'z']++fresh :: Infer Type+fresh = do+  s <- get+  put s {count = count s + 1}+  return $ TypeVar (letters !! count s)++addPos :: SrcLoc -> Predicate -> Located Predicate+addPos pos (IsIn x y) = Located pos $ IsIn x y++instantiate :: Scheme -> SrcLoc -> Infer (Type, [Located Predicate], [Located Dependency])+instantiate (Forall as (Qual ps ds t)) mpos = do+  as' <- mapM (const fresh) as+  let s = Subst $ Map.fromList $ zip as as'+  return (apply s t, map (addPos mpos) $ apply s ps, map (Located mpos) ds)++generalize :: [Predicate] -> [Dependency] -> LocType -> Scheme+generalize ps ds t = Forall as (Qual ps ds (lValue t))+  where+    as = Set.toList $ ftv t++filterAndCheck :: [Located Predicate] -> LocType -> Infer [Located Predicate]+filterAndCheck [] _ = return []+filterAndCheck (p@(Located _ (IsIn _ (TypeVar _))) : ps) t =+  if or $ Set.map (\x -> elem x $ ftv p) (ftv t)+    then (p :) <$> filterAndCheck ps t+    else filterAndCheck ps t+filterAndCheck (p : ps) t = checkInstance p >> filterAndCheck ps t++checkInstance :: Located Predicate -> Infer ()+checkInstance p = do+  (IEnv _ is) <- ask+  (if lValue p `elem` is then return () else throwError $ NoInstance p)++infer :: LocSimpleTerm -> Infer (Located Type, [Located Predicate], [Located Dependency], [Located Constraint])+infer expr = case expr of+  (Located p (SVar x)) -> do+    (t, ps, ds) <- lookupEnv (p, x)+    return (Located p t, ps, ds, [])+  (Located p (SText _)) -> return (Located p textT, [], [], [])+  (Located p (SNum _)) -> return (Located p numberT, [], [], [])+  (Located _ (SBracket s)) -> infer s+  Located p SRest -> do+    tv <- fresh+    return (Located p tv, [], [], [])+  (Located p (SLambda x e)) -> do+    tv <- fresh+    (t, ps, ds, cs) <- inEnv (x, Forall [] (Qual [] [] tv)) (infer e)+    return (Located p $ noLoc tv `TypeArr` t, ps, ds, cs)+  (Located p (SApp e1 e2)) -> do+    (t1, ps1, ds1, c1) <- infer e1+    (t2, ps2, ds2, c2) <- infer e2+    tv <- fresh+    return (noLoc tv, ps1 ++ ps2, ds1 ++ ds2, c1 ++ c2 ++ [Located p (lValue t1, t2 `TypeArr` noLoc tv)])+  (Located p (SInfix e1 op e2)) -> do+    (t1, ps1, ds1, c1) <- infer e1+    (t2, ps2, ds2, c2) <- infer e2+    tv <- fresh+    let u1 = t1 `TypeArr` Located (lLoc e2) (t2 `TypeArr` noLoc tv)+    (u2, p3, d3) <- lookupEnv (lLoc op, lValue op)+    return (noLoc tv, ps1 ++ ps2 ++ p3, ds1 ++ ds2 ++ d3, c1 ++ c2 ++ [Located p (u1, u2)])+  (Located _ (SSeq (x : xs))) -> do+    (t, ps, ds, cs) <- infer x+    infs <- mapM infer xs+    return (t, ps, ds ++ concatMap third4 infs, cs ++ concatMap fourth4 infs ++ [Located (lLoc t') (lValue t, lValue t') | t' <- map first4 infs])+  (Located _ (SStack (x : xs))) -> do+    (t, ps, ds, cs) <- infer x+    infs <- mapM infer xs+    return (t, ps, ds ++ concatMap third4 infs, cs ++ concatMap fourth4 infs ++ [Located (lLoc t') (lValue t, lValue t') | t' <- map first4 infs])+  (Located _ (SChoice _ (x : xs))) -> do+    (t, ps, ds, cs) <- infer x+    infs <- mapM infer xs+    return (t, ps, ds ++ concatMap third4 infs, cs ++ concatMap fourth4 infs ++ [Located (lLoc t') (lValue t, lValue t') | t' <- map first4 infs])+  _ -> throwError NotImplemented+  where+    first4 (x, _, _, _) = x+    third4 (_, _, x, _) = x+    fourth4 (_, _, _, x) = x++normalize :: Scheme -> Scheme+normalize (Forall _ (Qual ps ds body)) = Forall (map snd ord) (Qual (map normpred ps) ds (normtype body))+  where+    ord = zip (nub $ fv body) letters++    fv :: Type -> [TypeVar]+    fv (TypeVar a) = [a]+    fv (TypeArr a b) = fv (lValue a) ++ fv (lValue b)+    fv (TypeCon _) = []++    normtype :: Type -> Type+    normtype (TypeArr a b) = TypeArr (normtype <$> a) (normtype <$> b)+    normtype (TypeCon a) = TypeCon a+    normtype (TypeVar a) =+      case Prelude.lookup a ord of+        Just x -> TypeVar x+        Nothing -> error "type variable not in signature"++    normpred (IsIn n t) = IsIn n (normtype t)
+ src/zwirn-lang/Zwirn/Language/TypeCheck/Types.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Zwirn.Language.TypeCheck.Types where++{-+    Types.hs - defintion of types adapted from+    https://github.com/sdiehl/write-you-a-haskell/tree/master/chapter7/poly_constraints+    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 Data.Text (Text)+import Zwirn.Language.Location++type Name = Text++type TypeVar = Text++type LocType = Located Type++data Type+  = TypeVar TypeVar+  | TypeCon Text+  | TypeArr LocType LocType+  deriving (Show, Eq)++newtype Dependency+  = Dep Name+  deriving (Eq, Show)++data Predicate+  = IsIn Name Type+  deriving (Eq, Show)++data Qualified t+  = Qual [Predicate] [Dependency] t+  deriving (Show, Eq)++data Scheme+  = Forall [TypeVar] (Qualified Type)+  deriving (Show, Eq)++type Instance = Predicate++numberT :: Type+numberT = TypeCon "Number"++textT :: Type+textT = TypeCon "Text"++mapT :: Type+mapT = TypeCon "Map"++busT :: Type+busT = TypeCon "Bus"++soundT :: Type+soundT = TypeCon "Sound"++varA :: Type+varA = TypeVar "a"++varB :: Type+varB = TypeVar "b"++varC :: Type+varC = TypeVar "c"++isBasicType :: Scheme -> Bool+isBasicType (Forall _ (Qual _ _ (TypeCon _))) = True+isBasicType (Forall _ (Qual _ _ (TypeVar _))) = True+isBasicType _ = False++unqual :: Type -> Qualified Type+unqual = Qual [] []++schemeToType :: Scheme -> Type+schemeToType (Forall _ (Qual _ _ t)) = t++addDependency :: Text -> Scheme -> Scheme+addDependency x (Forall xs (Qual ps ds t)) = Forall xs (Qual ps (d : ds) t)+  where+    d = Dep x++checkDependency :: Text -> Scheme -> Bool+checkDependency x (Forall _ (Qual _ ds _)) = all check ds+  where+    check (Dep y) = x /= y
+ src/zwirn-lang/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-lang/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-lang/Zwirn/Stream/Process.hs view
@@ -0,0 +1,164 @@+{-# 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 view
@@ -0,0 +1,54 @@+{-# 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 view
@@ -0,0 +1,52 @@+{-# 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 view
@@ -0,0 +1,203 @@+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 and update the tempo variable+streamSetBPM :: Stream -> Time -> IO ()+streamSetBPM s t = streamSet s "tempo" (EZwirn $ pure $ ENum $ realToFrac t) >> Clock.setBPM (sClockRef s) t++-- | read the tempo variable+streamGetBPM :: Stream -> IO Double+streamGetBPM str = do+  st <- readMVar (sState str)+  (EZwirn zt) <- streamGet str "tempo"+  let vs = toList $ unzwirn zt 0 st+  case vs of+    [] -> return streamDefaultBPM+    (v : _) -> case value $ fst v of+      ENum x -> return x+      _ -> return streamDefaultBPM++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)
+ test/zwirn-core/Main.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE MultiParamTypeClasses #-}++import Control.Monad+import Data.Bifunctor (first)+import Data.Functor.Identity+import qualified Data.List as L+import qualified Data.Map as Map+import qualified Data.Ratio as R+import Test.Tasty+import Test.Tasty.HUnit+import Zwirn.Core.Cord as Z+import Zwirn.Core.Core+import Zwirn.Core.Lib.Conditional+import Zwirn.Core.Lib.Cord+import Zwirn.Core.Lib.Core+import Zwirn.Core.Lib.Map+import Zwirn.Core.Lib.Modulate+import Zwirn.Core.Lib.Number+import Zwirn.Core.Lib.Random+import Zwirn.Core.Lib.Structure+import Zwirn.Core.Query+import Zwirn.Core.Time+import Zwirn.Core.Tree (Tree (..))+import Zwirn.Core.Types++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests]++queryFirst :: Cord () () a -> [(Time, a)]+queryFirst = findAllValuesWithTime (Time 0 1, Time 1 1) ()++queryN :: Rational -> Cord () () a -> [(Time, a)]+queryN n = findAllValuesWithTime (Time 0 1, Time n 1) ()++(@?~) :: (Show a, Eq a) => [(Time, a)] -> [(Time, a)] -> Assertion+(@?~) actual expected = unless (Prelude.and check && length actual == length expected) (assertFailure msg)+  where+    msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual+    check = zipWith (\(a, v1) (b, v2) -> abs (a - b) < 0.01 && v1 == v2) expected actual++-- | should be used for signals+(~@?~) :: (Show a, Eq a, Fractional a, Ord a) => [(Time, a)] -> [(Time, a)] -> Assertion+(~@?~) actual expected = unless (Prelude.and check && length actual == length expected) (assertFailure msg)+  where+    msg = "expected: " ++ show expected ++ "\n but got: " ++ show actual+    check = zipWith (\(a, v1) (b, v2) -> abs (a - b) < 0.01 && (abs (v1 - v2) < 0.01)) expected actual++(%) :: Integer -> Integer -> Time+(%) x y = Time (x R.% y) (0 R.% 1)++simpleZwirn :: Cord () () Int+simpleZwirn = fastcat [pure 1, pure 2, pure 3, pure 4]++nestedZwirn :: Cord () () Int+nestedZwirn = fastcat [pure 10, pure 20, fastcat [pure 30, pure 40]]++veryNested :: Cord () () Int+veryNested = fastcat [simpleZwirn, nestedZwirn]++simpleCord :: Cord () () Int+simpleCord = stack [pure 10, simpleZwirn]++instance State Tree () () where+  beatsPerCycle = pure 8++unitTests =+  testGroup+    "Unit tests"+    [ testCase "pure for Zwirns" $+        queryFirst (pure 1 :: Cord () () Int) @?~ [(0, 1)],+      testCase "simple nesting" $+        queryFirst simpleZwirn @?~ [(0, 1), (1 % 4, 2), (1 % 2, 3), (3 % 4, 4)],+      testCase "more nesting" $+        queryFirst nestedZwirn @?~ [(0, 10), (1 % 3, 20), (2 % 3, 30), (5 % 6, 40)],+      testCase "very nested" $+        queryFirst veryNested @?~ [(0, 1), (1 % 8, 2), (2 % 8, 3), (3 % 8, 4), (1 % 2, 10), (4 % 6, 20), (5 % 6, 30), (11 % 12, 40)],+      testCase "reverse simple Zwirn" $+        queryFirst (rev simpleZwirn) @?~ [(0, 4), (1 % 4, 3), (1 % 2, 2), (3 % 4, 1)],+      testCase "reverse more nesting" $+        queryFirst (rev nestedZwirn) @?~ [(0, 40), (1 % 6, 30), (1 % 3, 20), (2 % 3, 10)],+      testCase "reverse inside" $+        queryFirst (fastcat [pure 100, rev simpleZwirn, pure 200, pure 300]) @?~ [(0, 100), (4 % 16, 4), (5 % 16, 3), (6 % 16, 2), (7 % 16, 1), (1 % 2, 200), (3 % 4, 300)],+      testCase "reverse reverse inside" $+        queryFirst (rev $ fastcat [pure 100, rev simpleZwirn, pure 200, pure 300]) @?~ [(0, 300), (1 % 4, 200), (8 % 16, 1), (9 % 16, 2), (10 % 16, 3), (11 % 16, 4), (3 % 4, 100)],+      testCase "squeezeJoin" $+        queryFirst (squeezeJoin $ fmap (const $ fastcat [pure 10, pure 20 :: Cord () () Int]) simpleZwirn) @?~ [(0, 10), (1 % 8, 20), (2 % 8, 10), (3 % 8, 20), (4 % 8, 10), (5 % 8, 20), (6 % 8, 10), (7 % 8, 20)],+      testCase "ply" $+        queryFirst (ply (pure 2) simpleZwirn) @?~ [(0, 1), (1 / 8, 1), (1 / 4, 2), (3 / 8, 2), (1 / 2, 3), (5 / 8, 3), (3 / 4, 4), (7 / 8, 4)],+      testCase "loop" $+        queryFirst (loop (pure 0.25) (pure 0.75) simpleZwirn) @?~ [(0, 2), (1 / 4, 3), (1 / 2, 2), (3 / 4, 3)],+      testCase "zoom rev" $+        queryFirst (zoom (pure 1) (pure 0) simpleZwirn) @?~ queryFirst (rev simpleZwirn),+      testCase "timeloop" $+        queryFirst (timeloop (pure 0.25) simpleZwirn) @?~ [(0, 1), (1 / 4, 1), (1 / 2, 1), (3 / 4, 1)],+      testCase "cat" $+        queryN 4 (cat (0.25, pure 1) (0.25, pure 2)) @?~ [(0, 1), (1 / 4, 2), (2, 1), (9 / 4, 2)],+      testCase "cyclecat" $+        queryN 3 (cyclecat [(1, pure 10), (2, slow (pure 2) $ pure 20)]) @?~ [(0, 10), (1, 20)],+      testCase "cyclecat 2" $+        queryN 2 (cyclecat [(0.5, pure 10), (1, pure 20), (0.5, pure 30)]) @?~ [(0, 10), (1 / 2, 20), (3 / 2, 30)],+      testCase "fastcyclecat" $+        queryFirst (fastcyclecat [(0.25, pure 1), (0.25, pure 2)]) @?~ [(0, 1), (1 / 4, 2), (1 / 2, 1), (3 / 4, 2)],+      testCase "fastcyclecat2" $+        queryFirst (fastcyclecat [(0.5, pure 1), (0.25, pure 2)]) @?~ [(0, 1), (1 / 2, 2), (3 / 4, 1)],+      testCase "euclid" $+        queryFirst (euclid (pure 3) (pure 8) (pure 1)) @?~ [(0, 1), (3 / 8, 1), (3 / 4, 1)],+      testCase "everyFor" $+        queryFirst (everyFor (pure 1) (pure 0.5) (pure $ fmap succ) simpleZwirn) @?~ [(0, 2), (1 / 4, 3), (1 / 2, 3), (3 / 4, 4)],+      testCase "everyFor 2" $+        queryN 2 (everyFor (pure 0.75) (pure 0.5) (pure $ fmap (const 100)) simpleZwirn) @?~ [(0, 100), (1 / 4, 100), (1 / 2, 3), (3 / 4, 100), (1, 100), (5 / 4, 2), (3 / 2, 100), (7 / 4, 100)],+      testCase "ifthen" $+        queryFirst (ifthen (fastcat [pure True, pure False]) (pure 10) (fastcat [pure 20, pure 30])) @?~ [(0, 10), (1 / 2, 30)],+      testCase "ifthen 2" $+        queryFirst (ifthen (fastcat [pure True, pure False]) simpleZwirn simpleZwirn) @?~ [(0, 1), (1 / 4, 2), (1 / 2, 3), (3 / 4, 4)],+      testCase "while" $+        queryFirst (while (fastcat [pure True, pure False]) (pure $ fmap succ) simpleZwirn) @?~ [(0, 2), (1 / 4, 3), (1 / 2, 3), (3 / 4, 4)],+      testCase "simpleCord" $+        queryFirst simpleCord @?~ [(0, 10), (0, 1), (1 / 4, 2), (1 / 2, 3), (3 / 4, 4)],+      testCase "enum cord" $+        queryFirst (enumFromToStack (pure 0) (pure 4)) @?~ [(0, 0), (0, 1), (0, 2), (0, 3)],+      testCase "zipApply" $+        queryFirst (zipApply (stack [pure $ fmap (+ 10), pure $ fmap (+ 100)]) (stack [fastcat [pure 1, pure 2], pure 3])) @?~ [(0 % 1, 11), (0 % 1, 103), (1 % 2, 12)],+      testCase "sine" $+        queryFirst (segment (pure 4) sine) ~@?~ [(0, 0.5), (1 / 4, 1), (1 / 2, 0.5), (3 / 4, 0)],+      testCase "rev sine" $+        queryFirst (segment (pure 4) $ rev sine) ~@?~ [(0, 0.5), (1 / 4, 0), (1 / 2, 0.5), (3 / 4, 1)],+      testCase "singleton" $+        queryFirst (singleton (pure "n") (fast (pure 2) $ pure 1)) @?~ [(0, Map.singleton "n" 1), (1 / 2, Map.singleton "n" 1)],+      testCase "union" $+        queryFirst (singleton (pure "n") (fast (pure 2) $ pure 1) `union` singleton (pure "s") (pure 1))+          @?~ [ (0, Map.singleton "n" 1 `Map.union` Map.singleton "s" 1),+                (1 / 2, Map.singleton "n" 1 `Map.union` Map.singleton "s" 1)+              ],+      testCase "fix" $+        queryFirst (fix (fastcat [pure "n"]) (pure $ const $ pure 10) (singleton (pure "n") (fast (pure 2) $ pure 1) `union` singleton (pure "s") (pure 1)))+          @?~ [ (0, Map.singleton "n" 10 `Map.union` Map.singleton "s" 1),+                (1 / 2, Map.singleton "n" 10 `Map.union` Map.singleton "s" 1)+              ],+      testCase "fix 2" $+        queryFirst (fix (fastcat [pure "n", pure "s"]) (pure $ const $ pure 10) (singleton (pure "n") (fast (pure 2) $ pure 1) `union` singleton (pure "s") (pure 1)))+          @?~ [ (0, Map.singleton "n" 10 `Map.union` Map.singleton "s" 1),+                (1 / 2, Map.singleton "n" 1 `Map.union` Map.singleton "s" 10)+              ],+      testCase "chunked" $+        queryFirst (chunked (pure "I:") (pure 1))+          @?~ [(0, 1), (1 / 4, 1), (3 / 8, 1), (1 / 2, 1), (3 / 4, 1), (7 / 8, 1)],+      testCase "chunked2" $+        queryFirst (fast (pure $ 5 / 8) $ chunked (pure "vi") (pure 1))+          @?~ [(1 / 5, 1), (2 / 5, 1), (3 / 5, 1), (4 / 5, 1)],+      testCase "chunked3" $+        queryFirst (chunked (pure "i~") (fastcat [pure 1, pure 2]))+          @?~ [(0, 1), (1 / 8, 1), (1 / 4, 1), (1 / 2, 2), (5 / 8, 2), (3 / 4, 2)],+      testCase "chunk" $+        queryFirst (chunk (pure "i~"))+          @?~ [(0, 0), (1 / 8, 1), (1 / 4, 2), (1 / 2, 0), (5 / 8, 1), (3 / 4, 2)],+      testCase "nested chunk" $+        queryFirst (slow (pure 2) $ chunked (pure "I[:]~") (pure 1))+          @?~ [(0, 1), (1 / 2, 1), (5 / 8, 1)],+      testCase "binary" $+        queryFirst (slow (pure 2) $ chunked (binary (pure 5)) (pure 1))+          @?~ [(0, 1), (1 / 2, 1), (3 / 4, 1)],+      testCase "christoffel" $+        queryFirst (chunked (christoffel (pure 3) (pure 5)) (pure 1))+          @?~ [(0, 1), (1 / 8, 1), (3 / 8, 1), (1 / 2, 1), (3 / 4, 1)],+      testCase "silence" $+        queryFirst (fastcat [silence, pure 2, silence, pure 4])+          @?~ [(1 / 4, 2), (3 / 4, 4)],+      testCase "everyBeat" $+        queryFirst (everyBeat (pure 4) (pure $ \x -> x + 1) simpleZwirn)+          @?~ [(0, 2), (1 / 4, 2), (1 / 2, 4), (3 / 4, 4)]+    ]
+ test/zwirn-lang/Main.hs view
@@ -0,0 +1,15 @@+import Control.Monad (unless)+import Test.Tasty+import Test.Tasty.HUnit+import Zwirn.Language.Syntax++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [unitTests]++unitTests =+  testGroup+    "Unit tests"+    []
zwirn.cabal view
@@ -1,10 +1,10 @@ cabal-version:      3.0 name:               zwirn-version:            0.1.0.0+version:            0.2.2.0 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'-                    mini-notation and it's API for manipulating patterns.+                    mini-notation and its API for manipulating patterns. license:            GPL-3.0-only license-file:       LICENSE author:             Martin Gius@@ -13,16 +13,66 @@ category:           Language, Sound build-type:         Simple extra-doc-files:    README.md-tested-with:        GHC == 9.8.2+tested-with:        GHC == 9.12.1, GHC == 9.8.2, GHC == 8.10.7 -source-repository this+source-repository head   type:              git-  location:          https://github.com/polymorphicengine/zwirn-  tag:               0.1.0.0+  location:          https://codeberg.org/uzu/zwirn/ +common common-options+  ghc-options:         -Wall+                       -Wincomplete-uni-patterns+                       -Wincomplete-record-updates+                       -Wcompat+                       -Widentities+                       -Wredundant-constraints+                 --      -Wmissing-export-lists+                       -Wpartial-fields -library-  hs-source-dirs: src+  default-language:    Haskell2010+  default-extensions:  OverloadedStrings++common common-deps+  build-depends:    base >= 4.14 && < 4.22,+                    mtl >= 2.3 && < 2.4,+                    containers >= 0.6.8 && < 0.8,+                    text >= 2 && < 2.2,++++library zwirn-core+    import:          common-options,+                     common-deps+    visibility:      public+    hs-source-dirs:  src/zwirn-core+    exposed-modules: Zwirn.Core.Time+                     Zwirn.Core.Core+                     Zwirn.Core.Tree+                     Zwirn.Core.Query+                     Zwirn.Core.Types+                     Zwirn.Core.Cord+                     Zwirn.Core.Lib.Cord+                     Zwirn.Core.Lib.Core+                     Zwirn.Core.Lib.Random+                     Zwirn.Core.Lib.Text+                     Zwirn.Core.Lib.State+                     Zwirn.Core.Lib.Modulate+                     Zwirn.Core.Lib.Structure+                     Zwirn.Core.Lib.Conditional+                     Zwirn.Core.Lib.Number+                     Zwirn.Core.Lib.Map+    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,++++library zwirn-lang+  import:          common-options,+                   common-deps+  visibility:      public+  hs-source-dirs:  src/zwirn-lang   exposed-modules: Zwirn.Language.TypeCheck.Types                    Zwirn.Language.TypeCheck.Constraint                    Zwirn.Language.TypeCheck.Infer@@ -34,6 +84,8 @@                    Zwirn.Language.Simple                    Zwirn.Language.Pretty                    Zwirn.Language.Block+                   Zwirn.Language.Macro+                   Zwirn.Language.Location                    Zwirn.Language.Builtin.Internal                    Zwirn.Language.Builtin.Prelude                    Zwirn.Language.Builtin.Parameters@@ -43,22 +95,127 @@                    Zwirn.Language.Evaluate.Expression                    Zwirn.Language.Evaluate.SKI                    Zwirn.Language.Evaluate.Internal+                   Zwirn.Language.LSP.Hover+                   Zwirn.Language.LSP.Eval+                   Zwirn.Language.LSP.Diagnostics+                   Zwirn.Language.LSP.InlayHints                    Zwirn.Language-                   Zwirn.Stream-  build-depends: array >= 0.5.6 && < 0.6,-                 base >= 4.17 && < 4.20,-                 bytestring >= 0.12.1 && < 0.13,-                 pretty >= 1.1.3 && < 1.2,-                 containers >= 0.6.8 && < 0.7,-                 exceptions >= 0.10.9 && < 0.11,-                 mtl >= 2.3.1 && < 2.4,-                 filepath >= 1.5.4 && < 1.6,-                 hosc >= 0.21.1 && < 0.22,-                 text >= 2.1.1 && < 2.2,-                 network >= 3.2.7 && < 3.3,-                 zwirn-core >= 0.1.1 && < 0.2,-                 tidal-link >= 1.1 && < 1.2+                   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++  build-depends:   zwirn:zwirn-core,+                   array >= 0.5 && < 0.6,+                   bytestring >= 0.12.1 && < 0.13,+                   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-  default-language: Haskell2010-  ghc-options: -threaded-               -Wall++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+                      LSP.Handlers.Action+                      LSP.Handlers.Command+                      LSP.Handlers.Completion+                      LSP.Handlers.File+                      LSP.Handlers.Hover+                      LSP.Handlers.InlayHint+    build-depends:    zwirn:zwirn-core,+                      zwirn:zwirn-lang,+                      tidal-link >= 1.1 && < 1.2,+                      bytestring >= 0.12.1 && < 0.13,+                      exceptions >= 0.10.9 && < 0.11,+                      lsp >= 2.7 && < 2.7.1,+                      haskeline >= 0.8.4 && < 0.9,+                      file-io >= 0.1.5 && < 0.1.6,+                      filepath >= 1.5.4 && < 1.5.5,+                      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,+                      text-rope >= 0.3 && < 0.4,+                      aeson >= 2.2.3 && < 2.2.4+    default-language: Haskell2010+    ghc-options:      -threaded++executable zwirn-plot+    import:         common-options,+                    common-deps+    hs-source-dirs:   app/zwirn-plot+    main-is:          Main.hs+    build-depends:  zwirn:zwirn-core,+                    easyplot >= 1 && < 1.1+    default-language: Haskell2010+    ghc-options:      -threaded++executable zwirn-docs+    import:         common-options,+                    common-deps+    hs-source-dirs:   app/zwirn-docs+    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+    default-language: Haskell2010+    ghc-options:      -threaded+++test-suite test-zwirn-core+    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,+                       tasty-hunit >= 0.10.1,+    default-language:  Haskell2010+    ghc-options:       -threaded++test-suite test-zwirn-lang+    type:              exitcode-stdio-1.0+    hs-source-dirs:    test/zwirn-lang/+    main-is:           Main.hs+    build-depends:     zwirn:zwirn-lang,+                       base >= 4.14 && < 4.22,+                       tasty >= 1.5,+                       tasty-smallcheck >= 0.8.2,+                       tasty-quickcheck >= 0.10.3,+                       tasty-hunit >= 0.10.1,+    default-language:  Haskell2010+    ghc-options:       -threaded+++benchmark bench-zwirn-core+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   bench/Core+    build-depends:+                      base >= 4.14 && < 4.22,+                      criterion >=1.6.4 && < 1.6.5,+                      deepseq,+                      zwirn:zwirn-core,+    default-language: Haskell2010+    ghc-options:      -Wall