diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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.
diff --git a/app/zwirn-docs/Main.hs b/app/zwirn-docs/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirn-docs/Main.hs
@@ -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) ++ "```"
diff --git a/app/zwirn-plot/Main.hs b/app/zwirn-plot/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirn-plot/Main.hs
@@ -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
diff --git a/app/zwirnzi/CI/Backend.hs b/app/zwirnzi/CI/Backend.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/Backend.hs
@@ -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 .
+-}
+
+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
diff --git a/app/zwirnzi/CI/Config.hs b/app/zwirnzi/CI/Config.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/Config.hs
@@ -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 .
+-}
+
+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
diff --git a/app/zwirnzi/CI/Setup.hs b/app/zwirnzi/CI/Setup.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/CI/Setup.hs
@@ -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 .
+-}
+
+import CI.Config as C
+import Control.Concurrent (forkIO)
+import Control.Monad (void, when)
+import qualified Data.Map as Map
+import qualified Data.Text as T
+import System.Directory.OsPath
+import System.IO (hPutStrLn, stderr)
+import System.OsPath
+import Zwirn.Language.Builtin.Prelude
+import Zwirn.Language.Compiler as Compiler
+import Zwirn.Language.Macro (defaultMacroMap)
+import Zwirn.Stream.Handshake (sendHandshake)
+import Zwirn.Stream.Listen
+import Zwirn.Stream.Target (Target (..))
+import Zwirn.Stream.Types
+import Zwirn.Stream.UI
+
+setup :: FullConfig -> IO Environment
+setup config = do
+ str <- setupStream config
+ when (ciConfigListener $ fullConfigCi config) (setupListener str)
+ let initE = getInitialEnv (toCiConfig $ fullConfigCi config) str
+ checkBoot (fullConfigCi config) initE
+
+setupStream :: FullConfig -> IO Stream
+setupStream config = startStream (toStream $ fullConfigStream config)
+
+setupListener :: Stream -> IO ()
+setupListener str = do
+ case Map.lookup "superdirt" (sTargetMap str) of
+ Nothing -> return ()
+ Just (Target _ _ addr _) -> sendHandshake (sLocal str) addr
+ void (forkIO $ listen str)
+
+getInitialEnv :: Compiler.CiConfig -> Stream -> Environment
+getInitialEnv config str = Environment str (builtinEnvironmentWithStream str) (Just $ ConfigEnv configPath resetConfig) config defaultMacroMap
+
+checkBoot :: C.CiConfig -> Environment -> IO Environment
+checkBoot (C.CiConfig "" _ _ _ _) env = hPutStrLn stderr "Starting without Bootfile." >> return env
+checkBoot (C.CiConfig path _ _ _ _) env = do
+ ospath <- encodeUtf path
+ isfile <- doesFileExist ospath
+ ps <-
+ if isfile
+ then return $ decodeUtf ospath
+ else do
+ isfolder <- doesDirectoryExist ospath
+ if isfolder
+ then do
+ pss <- listDirectory ospath
+ fs <- mapM decodeUtf pss
+ return $ map (\f -> path ++ "/" ++ f) fs
+ else return []
+ res <- runCI env (compilerInterpreterBoot $ map T.pack ps)
+ case res of
+ Left (CIError err newEnv) -> hPutStrLn stderr ("Error in Bootfile: " ++ show err) >> return newEnv
+ Right newEnv ->
+ if ps /= []
+ then hPutStrLn stderr ("Successfully loaded Bootfiles from " ++ path) >> return newEnv
+ else hPutStrLn stderr ("No Bootfiles found at " ++ path) >> return newEnv
diff --git a/app/zwirnzi/LSP/Diagnostic.hs b/app/zwirnzi/LSP/Diagnostic.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Diagnostic.hs
@@ -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 _ = []
diff --git a/app/zwirnzi/LSP/Handlers/Action.hs b/app/zwirnzi/LSP/Handlers/Action.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Handlers/Action.hs
@@ -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]
diff --git a/app/zwirnzi/LSP/Handlers/Command.hs b/app/zwirnzi/LSP/Handlers/Command.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Handlers/Command.hs
@@ -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
diff --git a/app/zwirnzi/LSP/Handlers/Completion.hs b/app/zwirnzi/LSP/Handlers/Completion.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Handlers/Completion.hs
@@ -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
diff --git a/app/zwirnzi/LSP/Handlers/File.hs b/app/zwirnzi/LSP/Handlers/File.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Handlers/File.hs
@@ -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 ()
diff --git a/app/zwirnzi/LSP/Handlers/Hover.hs b/app/zwirnzi/LSP/Handlers/Hover.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Handlers/Hover.hs
@@ -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 ()
diff --git a/app/zwirnzi/LSP/Handlers/InlayHint.hs b/app/zwirnzi/LSP/Handlers/InlayHint.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Handlers/InlayHint.hs
@@ -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 ())
diff --git a/app/zwirnzi/LSP/Main.hs b/app/zwirnzi/LSP/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Main.hs
@@ -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 ()
diff --git a/app/zwirnzi/LSP/Util.hs b/app/zwirnzi/LSP/Util.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/LSP/Util.hs
@@ -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)
diff --git a/app/zwirnzi/Main.hs b/app/zwirnzi/Main.hs
new file mode 100644
--- /dev/null
+++ b/app/zwirnzi/Main.hs
@@ -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 .
+-}
+
+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
diff --git a/bench/Core/Main.hs b/bench/Core/Main.hs
new file mode 100644
--- /dev/null
+++ b/bench/Core/Main.hs
@@ -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)
+ ]
+ ]
diff --git a/src/Zwirn/Language.hs b/src/Zwirn/Language.hs
deleted file mode 100644
--- a/src/Zwirn/Language.hs
+++ /dev/null
@@ -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 .
--}
diff --git a/src/Zwirn/Language/Block.hs b/src/Zwirn/Language/Block.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Block.hs
+++ /dev/null
@@ -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 .
--}
-
-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)
diff --git a/src/Zwirn/Language/Builtin/Internal.hs b/src/Zwirn/Language/Builtin/Internal.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Builtin/Internal.hs
+++ /dev/null
@@ -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)
diff --git a/src/Zwirn/Language/Builtin/Parameters.hs b/src/Zwirn/Language/Builtin/Parameters.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Builtin/Parameters.hs
+++ /dev/null
@@ -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
diff --git a/src/Zwirn/Language/Builtin/Prelude.hs b/src/Zwirn/Language/Builtin/Prelude.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Builtin/Prelude.hs
+++ /dev/null
@@ -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 .
--}
-
-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 == ```",
- "slowrunFromThenTo"
- === toExp (slowrunFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)
- <:: "Number -> Number -> Number -> Number"
- --| "```slowrunFromTo 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"
- ]
diff --git a/src/Zwirn/Language/Compiler.hs b/src/Zwirn/Language/Compiler.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Compiler.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/Environment.hs b/src/Zwirn/Language/Environment.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Environment.hs
+++ /dev/null
@@ -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
diff --git a/src/Zwirn/Language/Evaluate.hs b/src/Zwirn/Language/Evaluate.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Evaluate.hs
+++ /dev/null
@@ -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
diff --git a/src/Zwirn/Language/Evaluate/Convert.hs b/src/Zwirn/Language/Evaluate/Convert.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Evaluate/Convert.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/Evaluate/Expression.hs b/src/Zwirn/Language/Evaluate/Expression.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Evaluate/Expression.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/Evaluate/Internal.hs b/src/Zwirn/Language/Evaluate/Internal.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Evaluate/Internal.hs
+++ /dev/null
@@ -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 .
--}
-
-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)
diff --git a/src/Zwirn/Language/Evaluate/SKI.hs b/src/Zwirn/Language/Evaluate/SKI.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Evaluate/SKI.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/Lexer.x b/src/Zwirn/Language/Lexer.x
deleted file mode 100644
--- a/src/Zwirn/Language/Lexer.x
+++ /dev/null
@@ -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 .
--}
-
-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+ ;
-
- (.+ (\n?) | \n) { mkLine }
-
- $white+ ;
- $alpha+ "." ;
- "=>" { tok Context }
- "->" { tok Arrow }
- "(" { tok LPar }
- ")" { tok RPar }
- "," { tok Comma }
- "Text" { tok TextToken }
- "Number" { tok NumberToken }
- "Map" { tok MapToken }
- "Bus" { tok BusToken }
- @id { tokText VarToken }
- [A-Z] $alphasmall+ { tokText TypeClass }
- @id { tokText Identifier }
- @op { tokText Operator }
- @specialop { tokText SpecialOp }
-
--- Multi Line Comments
-
-<0> "{-" { nestComment `andBegin` comment }
-<0> "-}" { \_ _ -> alexError "Error: unexpected closing comment" }
- "{-" { nestComment }
- "-}" { unnestComment }
- . ;
- \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
-}
diff --git a/src/Zwirn/Language/Parser.y b/src/Zwirn/Language/Parser.y
deleted file mode 100644
--- a/src/Zwirn/Language/Parser.y
+++ /dev/null
@@ -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 .
--}
-
-
-}
-
-%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)
-
-}
diff --git a/src/Zwirn/Language/Pretty.hs b/src/Zwirn/Language/Pretty.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Pretty.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/Rotate.hs b/src/Zwirn/Language/Rotate.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Rotate.hs
+++ /dev/null
@@ -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 .
--}
-
-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)
diff --git a/src/Zwirn/Language/Simple.hs b/src/Zwirn/Language/Simple.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Simple.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/Syntax.hs b/src/Zwirn/Language/Syntax.hs
deleted file mode 100644
--- a/src/Zwirn/Language/Syntax.hs
+++ /dev/null
@@ -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 .
--}
-
-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)
diff --git a/src/Zwirn/Language/TypeCheck/Constraint.hs b/src/Zwirn/Language/TypeCheck/Constraint.hs
deleted file mode 100644
--- a/src/Zwirn/Language/TypeCheck/Constraint.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/Zwirn/Language/TypeCheck/Infer.hs b/src/Zwirn/Language/TypeCheck/Infer.hs
deleted file mode 100644
--- a/src/Zwirn/Language/TypeCheck/Infer.hs
+++ /dev/null
@@ -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 .
--}
-
-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)
diff --git a/src/Zwirn/Language/TypeCheck/Types.hs b/src/Zwirn/Language/TypeCheck/Types.hs
deleted file mode 100644
--- a/src/Zwirn/Language/TypeCheck/Types.hs
+++ /dev/null
@@ -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 .
--}
-
-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 []
diff --git a/src/Zwirn/Stream.hs b/src/Zwirn/Stream.hs
deleted file mode 100644
--- a/src/Zwirn/Stream.hs
+++ /dev/null
@@ -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 .
--}
-
-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
diff --git a/src/zwirn-core/Zwirn/Core/Cord.hs b/src/zwirn-core/Zwirn/Core/Cord.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Cord.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Core.hs b/src/zwirn-core/Zwirn/Core/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Core.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Conditional.hs b/src/zwirn-core/Zwirn/Core/Lib/Conditional.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Conditional.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Cord.hs b/src/zwirn-core/Zwirn/Core/Lib/Cord.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Cord.hs
@@ -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 .
+-}
+
+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]
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Core.hs b/src/zwirn-core/Zwirn/Core/Lib/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Core.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Map.hs b/src/zwirn-core/Zwirn/Core/Lib/Map.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Map.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs b/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Modulate.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Number.hs b/src/zwirn-core/Zwirn/Core/Lib/Number.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Number.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Random.hs b/src/zwirn-core/Zwirn/Core/Lib/Random.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Random.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-core/Zwirn/Core/Lib/State.hs b/src/zwirn-core/Zwirn/Core/Lib/State.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/State.hs
@@ -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 .
+-}
+
+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))
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Structure.hs b/src/zwirn-core/Zwirn/Core/Lib/Structure.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Structure.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Lib/Text.hs b/src/zwirn-core/Zwirn/Core/Lib/Text.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Lib/Text.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Query.hs b/src/zwirn-core/Zwirn/Core/Query.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Query.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-core/Zwirn/Core/Time.hs b/src/zwirn-core/Zwirn/Core/Time.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Time.hs
@@ -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 .
+-}
+
+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')))
diff --git a/src/zwirn-core/Zwirn/Core/Tree.hs b/src/zwirn-core/Zwirn/Core/Tree.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Tree.hs
@@ -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 .
+-}
+
+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]
diff --git a/src/zwirn-core/Zwirn/Core/Types.hs b/src/zwirn-core/Zwirn/Core/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-core/Zwirn/Core/Types.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-lang/Zwirn/Language.hs b/src/zwirn-lang/Zwirn/Language.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language.hs
@@ -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 .
+-}
diff --git a/src/zwirn-lang/Zwirn/Language/Block.hs b/src/zwirn-lang/Zwirn/Language/Block.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Block.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Builtin/Internal.hs b/src/zwirn-lang/Zwirn/Language/Builtin/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Builtin/Internal.hs
@@ -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)
diff --git a/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs b/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Builtin/Parameters.hs
@@ -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]
diff --git a/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs b/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Builtin/Prelude.hs
@@ -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 .
+-}
+
+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 == ```",
+ "slowrunFromThenTo"
+ === toExp (slowrunFromThenTo :: Zwirn Double -> Zwirn Double -> Zwirn Double -> Zwirn Double)
+ <:: "Number -> Number -> Number -> Number"
+ --| "```slowrunFromTo 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"
+ --| ""
+ ]
diff --git a/src/zwirn-lang/Zwirn/Language/Compiler.hs b/src/zwirn-lang/Zwirn/Language/Compiler.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Compiler.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Environment.hs b/src/zwirn-lang/Zwirn/Language/Environment.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Environment.hs
@@ -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
diff --git a/src/zwirn-lang/Zwirn/Language/Evaluate.hs b/src/zwirn-lang/Zwirn/Language/Evaluate.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Evaluate.hs
@@ -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
diff --git a/src/zwirn-lang/Zwirn/Language/Evaluate/Convert.hs b/src/zwirn-lang/Zwirn/Language/Evaluate/Convert.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Evaluate/Convert.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Evaluate/Expression.hs b/src/zwirn-lang/Zwirn/Language/Evaluate/Expression.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Evaluate/Expression.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs b/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Evaluate/Internal.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Evaluate/SKI.hs b/src/zwirn-lang/Zwirn/Language/Evaluate/SKI.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Evaluate/SKI.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/LSP/Diagnostics.hs b/src/zwirn-lang/Zwirn/Language/LSP/Diagnostics.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/LSP/Diagnostics.hs
@@ -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 ()
diff --git a/src/zwirn-lang/Zwirn/Language/LSP/Eval.hs b/src/zwirn-lang/Zwirn/Language/LSP/Eval.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/LSP/Eval.hs
@@ -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)
diff --git a/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs b/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/LSP/Hover.hs
@@ -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```"
diff --git a/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs b/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/LSP/InlayHints.hs
@@ -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
diff --git a/src/zwirn-lang/Zwirn/Language/Lexer.x b/src/zwirn-lang/Zwirn/Language/Lexer.x
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Lexer.x
@@ -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 .
+-}
+
+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
+ "--" .* (\n?) ;
+
+ (.+ (\n?) | \n) { mkLine }
+
+
+ $white+ ;
+ $alpha+ "." ;
+ "=>" { tok TypeContextTok }
+ "->" { tok ArrowTok }
+ "(" { tok LParTok }
+ ")" { tok RParTok }
+ "," { tok CommaTok }
+ "Text" { tok TextTypeTok }
+ "Number" { tok NumberTypeTok }
+ "Map" { tok MapTypeTok }
+ "Action" { tok ActionTypeTok }
+ @id { tokText VarTypeTok }
+ [A-Z] $alphasmall+ { tokText TypeClassTok }
+ @id { tokText IdentifierTok }
+ @op { tokText OperatorTok }
+ @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
+}
diff --git a/src/zwirn-lang/Zwirn/Language/Location.hs b/src/zwirn-lang/Zwirn/Language/Location.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Location.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-lang/Zwirn/Language/Macro.hs b/src/zwirn-lang/Zwirn/Language/Macro.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Macro.hs
@@ -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
diff --git a/src/zwirn-lang/Zwirn/Language/Parser.y b/src/zwirn-lang/Zwirn/Language/Parser.y
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Parser.y
@@ -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 .
+-}
+
+
+}
+
+%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)
+
+}
diff --git a/src/zwirn-lang/Zwirn/Language/Pretty.hs b/src/zwirn-lang/Zwirn/Language/Pretty.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Pretty.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Rotate.hs b/src/zwirn-lang/Zwirn/Language/Rotate.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Rotate.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-lang/Zwirn/Language/Simple.hs b/src/zwirn-lang/Zwirn/Language/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Simple.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/Syntax.hs b/src/zwirn-lang/Zwirn/Language/Syntax.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/Syntax.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/TypeCheck/Constraint.hs b/src/zwirn-lang/Zwirn/Language/TypeCheck/Constraint.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/TypeCheck/Constraint.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Language/TypeCheck/Infer.hs b/src/zwirn-lang/Zwirn/Language/TypeCheck/Infer.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/TypeCheck/Infer.hs
@@ -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 .
+-}
+
+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)
diff --git a/src/zwirn-lang/Zwirn/Language/TypeCheck/Types.hs b/src/zwirn-lang/Zwirn/Language/TypeCheck/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Language/TypeCheck/Types.hs
@@ -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 .
+-}
+
+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
diff --git a/src/zwirn-lang/Zwirn/Stream/Handshake.hs b/src/zwirn-lang/Zwirn/Stream/Handshake.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Stream/Handshake.hs
@@ -0,0 +1,29 @@
+module Zwirn.Stream.Handshake where
+
+import Control.Concurrent.MVar (MVar, swapMVar)
+import Control.Monad (void)
+import Data.Maybe (catMaybes, isJust)
+import qualified Sound.Osc as O
+import qualified Sound.Osc.Transport.Fd.Udp as O
+import Zwirn.Stream.Target
+
+-- handshake is in the responsibility of a specific listener implementation
+-- these functions can be used to implement it
+
+sendHandshake :: O.Udp -> RemoteAddress -> IO ()
+sendHandshake udp = O.sendTo udp (O.Packet_Message $ O.Message "/dirt/handshake" [])
+
+isHandshakeMsg :: O.Message -> Bool
+isHandshakeMsg (O.Message "/dirt/hello" _) = True
+isHandshakeMsg (O.Message "/dirt/handshake/reply" _) = True
+isHandshakeMsg _ = False
+
+actOnHandshake :: O.Message -> O.Udp -> RemoteAddress -> MVar [Int] -> IO ()
+actOnHandshake (O.Message "/dirt/hello" _) udp remote _ = sendHandshake udp remote
+actOnHandshake (O.Message "/dirt/handshake/reply" xs) _ _ bussesMV = void $ swapMVar bussesMV $ bufferIndices xs
+ where
+ bufferIndices [] = []
+ bufferIndices (x : xs')
+ | x == O.AsciiString (O.ascii "&controlBusIndices") = catMaybes $ takeWhile isJust $ map O.datum_integral xs'
+ | otherwise = bufferIndices xs'
+actOnHandshake _ _ _ _ = return ()
diff --git a/src/zwirn-lang/Zwirn/Stream/Listen.hs b/src/zwirn-lang/Zwirn/Stream/Listen.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Stream/Listen.hs
@@ -0,0 +1,48 @@
+module Zwirn.Stream.Listen where
+
+import Data.Bifunctor (first)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import qualified Network.Socket as N
+import Sound.Osc as O
+import Sound.Osc.Transport.Fd.Udp as O
+import Zwirn.Language.Evaluate (Expression (..))
+import Zwirn.Stream.Handshake
+import Zwirn.Stream.Types (Stream (..))
+import Zwirn.Stream.UI
+
+type RemoteAddress = N.SockAddr
+
+listen :: Stream -> IO ()
+listen str = recvMessageFrom (sLocal str) >>= act str >> listen str
+
+recvMessageFrom :: O.Udp -> IO (Maybe Message, RemoteAddress)
+recvMessageFrom loc = fmap (first packet_to_message) (recvFrom loc)
+
+act :: Stream -> (Maybe O.Message, RemoteAddress) -> IO ()
+act str (Just (Message "/ping" []), remote) = replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Double val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Float val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ realToFrac val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Int32 val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ fromIntegral val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, Int64 val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ ENum $ fromIntegral val) >> replyOk (sLocal str) remote
+act str (Just (Message "/ctrl" [AsciiString key, AsciiString val]), remote) = streamSet str (toUTF8 key) (EZwirn $ pure $ EText $ toUTF8 val) >> replyOk (sLocal str) remote
+act str (Just m, remote) =
+ if isHandshakeMsg m
+ then actOnHandshake m (sLocal str) remote (sBusses str)
+ else replyError (sLocal str) remote ("Unhandeled Message: " ++ show m)
+act _ _ = return ()
+
+reply :: O.Udp -> RemoteAddress -> O.Packet -> IO ()
+reply loc remote msg = O.sendTo loc msg remote
+
+replyOk :: O.Udp -> RemoteAddress -> IO ()
+replyOk loc = flip (reply loc) (O.p_message "/ok" [])
+
+replyError :: O.Udp -> RemoteAddress -> String -> IO ()
+replyError loc remote err = reply loc remote (O.p_message "/error" [utf8String err])
+
+utf8String :: String -> O.Datum
+utf8String s = O.AsciiString $ encodeUtf8 $ T.pack s
+
+toUTF8 :: O.Ascii -> T.Text
+toUTF8 = decodeUtf8
diff --git a/src/zwirn-lang/Zwirn/Stream/Process.hs b/src/zwirn-lang/Zwirn/Stream/Process.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Stream/Process.hs
@@ -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)
diff --git a/src/zwirn-lang/Zwirn/Stream/Target.hs b/src/zwirn-lang/Zwirn/Stream/Target.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Stream/Target.hs
@@ -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
diff --git a/src/zwirn-lang/Zwirn/Stream/Types.hs b/src/zwirn-lang/Zwirn/Stream/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Stream/Types.hs
@@ -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
+ }
diff --git a/src/zwirn-lang/Zwirn/Stream/UI.hs b/src/zwirn-lang/Zwirn/Stream/UI.hs
new file mode 100644
--- /dev/null
+++ b/src/zwirn-lang/Zwirn/Stream/UI.hs
@@ -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)
diff --git a/test/zwirn-core/Main.hs b/test/zwirn-core/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/zwirn-core/Main.hs
@@ -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)]
+ ]
diff --git a/test/zwirn-lang/Main.hs b/test/zwirn-lang/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/zwirn-lang/Main.hs
@@ -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"
+ []
diff --git a/zwirn.cabal b/zwirn.cabal
--- a/zwirn.cabal
+++ b/zwirn.cabal
@@ -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