diff --git a/Drum/Client.hs~ b/Drum/Client.hs~ deleted file mode 100644 index f007bba..0000000 --- a/Drum/Client.hs~ +++ /dev/null @@ -1,44 +0,0 @@ --- Released under terms of GNU Public License version 3 --- (c) Alex McLean 2017 - -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} - -module Drum.Client where - -import Control.Exception (try) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Network.WebSockets as WS -import Data.List -import Data.Maybe -import Control.Concurrent -import Control.Concurrent.MVar -import System.Directory -import System.FilePath -import System.IO -import Control.Monad (when) -import Control.Monad.Trans (liftIO) -import Data.Unique -import System.Environment (getArgs,lookupEnv) - --- import Data.Ratio --- import System.Process --- import Data.Time.Clock.POSIX --- import Data.Fixed (mod') --- import Text.JSON --- import qualified Data.ByteString.Lazy.Char8 as C --- import Control.Applicative - -port = 6010 - - -snapshot snapName = - do addr <- fromMaybe "127.0.0.1" <$> lookupEnv "CIRCLE_ADDR" - port <- fromMaybe "6010" <$> lookupEnv "CIRCLE_PORT" - WS.runClient addr (read port) "/" $ \conn -> do WS.sendTextData conn $ T.pack $ "/takeSnapshots " ++ snapName - msg <- WS.receiveData conn - putStrLn $ T.unpack msg - msg <- WS.receiveData conn - putStrLn $ T.unpack msg - diff --git a/Drum/Server.hs~ b/Drum/Server.hs~ deleted file mode 100644 index f14fa6b..0000000 --- a/Drum/Server.hs~ +++ /dev/null @@ -1,179 +0,0 @@ --- Released under terms of GNU Public License version 3 --- (c) Alex McLean 2017 - -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} - -module Drum.Server where - -import Control.Exception (try) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Network.WebSockets as WS -import Data.List -import Data.Maybe -import Control.Concurrent -import Control.Concurrent.MVar -import System.Directory -import System.FilePath -import System.IO -import Control.Monad (when) -import Control.Monad.Trans (liftIO) -import Data.Unique - --- import Data.Ratio --- import System.Process --- import Data.Time.Clock.POSIX --- import Data.Fixed (mod') --- import Text.JSON --- import qualified Data.ByteString.Lazy.Char8 as C --- import Control.Applicative - -port = 6010 - -data Client = Client {cName :: String, - cServerThread :: ThreadId, - cSender :: String -> IO (), - cFH :: Maybe Handle, - cConn :: WS.Connection, - cId :: Unique - } - -wsSend :: WS.Connection -> IO (ThreadId, String -> IO()) -wsSend conn = - do sendQueue <- newEmptyMVar - threadId <- (forkIO $ sender sendQueue) - return (threadId, putMVar sendQueue) - where - sender :: MVar String -> IO () - sender sendQueue = do s <- takeMVar sendQueue - WS.sendTextData conn (T.pack s) - sender sendQueue - -run = do - putStrLn $ "Drumming circle server, starting on port " ++ show port - mConnectionId <- newMVar 0 - mClients <- newMVar [] - WS.runServer "0.0.0.0" port $ (\pending -> do - conn <- WS.acceptRequest pending - - putStrLn $ "received new connection" - (senderThreadId, sender) <- wsSend conn - - sender $ "/welcome" - - WS.forkPingThread conn 30 - uniqueId <- liftIO newUnique - let client = Client {cName = "anonymous", - cServerThread = senderThreadId, - cSender = sender, - cFH = Nothing, - cConn = conn, - cId = uniqueId - } - clients <- liftIO $ takeMVar mClients - liftIO $ putMVar mClients $ client:clients - loop mClients client conn - ) - putStrLn "done." - -loop :: MVar [Client] -> Client -> WS.Connection -> IO () -loop mClients client conn = do - msg <- try (WS.receiveData conn) - -- add to dictionary of connections -> patterns, could use a map for this - case msg of - Right s -> do - putStrLn $ "msg: " ++ T.unpack s - client' <- act mClients client conn (T.unpack s) - clients <- takeMVar mClients - putMVar mClients $ updateClient clients client' - loop mClients client' conn - Left WS.ConnectionClosed -> close mClients client "unexpected loss of connection" - Left (WS.CloseRequest _ _) -> close mClients client "by request from peer" - Left (WS.ParseException e) -> close mClients client ("parse exception: " ++ e) - -removeClient :: [Client] -> Client -> [Client] -removeClient cs c = filter (\c' -> cId c' /= cId c) cs - -updateClient :: [Client] -> Client -> [Client] -updateClient cs c = c:(removeClient cs c) - -close :: MVar [Client] -> Client -> String -> IO () -close mClients client msg = do - putStrLn ("connection closed: " ++ msg) - let fh = cFH client - cs <- takeMVar mClients - putMVar mClients $ removeClient cs client - when (isJust fh) $ do - hClose $ fromJust fh --- hush = mapM_ ($ Tidal.silence) - --- TODO: proper parsing.. -takeNumbers :: String -> (String, String) -takeNumbers xs = (takeWhile f xs, dropWhile (== ' ') $ dropWhile f xs) - where f x = not . null $ filter (x ==) "0123456789." - -commands = [("name", act_name), - ("change", act_change), - ("takeSnapshots", act_takeSnapshots) - {-("play", act_play), - ("record", act_record), - ("typecheck", act_typecheck) , - ("renderJSON", act_renderJSON) , - ("renderSVG", act_renderSVG), - ("panic", act_panic), - ("wantbang", act_wantbang), - ("shutdown", act_shutdown), - ("nudge", act_nudge), - ("cps_delta ", act_cps_delta), - ("cps", act_cps), - ("bang", act_bang True), - ("nobang", act_bang False)-} - ] - -getCommand :: String -> Maybe (MVar [Client] -> Client -> WS.Connection -> IO Client) -getCommand ('/':s) = do f <- lookup command commands - param <- stripPrefix command s - let param' = dropWhile (== ' ') param - return $ f param' - where command = takeWhile (/= ' ') s -getCommand _ = Nothing - -act :: MVar [Client] -> Client -> WS.Connection -> String -> IO Client -act mClients client conn request = (fromMaybe act_no_parse $ getCommand request) mClients client conn - -act_no_parse _ client conn = do cSender client $ "/noparse" - return client - - -act_name :: String -> MVar [Client] -> Client -> WS.Connection -> IO (Client) -act_name param _ client conn = - do putStrLn $ "name: '" ++ param ++ "'" - cSender client $ "/name ok hello " ++ param - return $ client {cName = param} - -act_change :: String -> MVar [Client] -> Client -> WS.Connection -> IO (Client) -act_change param _ client conn = - do fh <- getFH (cFH client) - hPutStrLn fh $ "//" - hPutStrLn fh param - hFlush fh - return (client {cFH = Just fh}) - where getFH (Just fh) = return fh - getFH Nothing = - do createDirectoryIfMissing True logDirectory - fh <- openFile fn AppendMode - hPutStrLn fh $ "// connect" - return fh - fn = "logs" (cName client) ++ ".json" - logDirectory = "logs" - - -act_takeSnapshots :: String -> MVar [Client] -> Client -> WS.Connection -> IO (Client) -act_takeSnapshots param mClients client conn = - do putStrLn $ "takeSnapshot [" ++ param ++ "]." - cs <- readMVar mClients - mapM_ (\conn -> WS.sendTextData conn (T.pack $ "/takeSnapshot " ++ param)) $ map cConn cs - return $ client - - diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 6ce4ec3..0000000 --- a/Main.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where - -import qualified Feedforward.Edit as E - -main = E.main diff --git a/Server.hs b/Server.hs_bak similarity index 56% rename from Server.hs rename to Server.hs_bak index 6d14239..57a953d 100644 --- a/Server.hs +++ b/Server.hs_bak @@ -1,5 +1,5 @@ module Main where -import Drum.Server +import Server main = run diff --git a/feedforward.cabal b/feedforward.cabal new file mode 100644 index 0000000..6b23106 --- /dev/null +++ b/feedforward.cabal @@ -0,0 +1,69 @@ +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 997ed186d08ff264c26ba5714b27983ffb7c84c2a307fc559d44c6043adc7f74 + +name: feedforward +version: 0.0.1 +copyright: 2018 Author name here +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + hs-source-dirs: + src + build-depends: + aeson + , base + , directory + , filepath + , hint + , hosc + , mtl + , ncurses + , network + , text + , tidal + , time + , unix + , websockets + exposed-modules: + Change + Client + Edit + Main + Server + TidalHint + other-modules: + Paths_feedforward + default-language: Haskell2010 + +executable feedforward + main-is: Main.hs + hs-source-dirs: + src + build-depends: + aeson + , base + , directory + , filepath + , hint + , hosc + , mtl + , ncurses + , network + , text + , tidal + , time + , unix + , websockets + other-modules: + Change + Client + Edit + Server + TidalHint + Paths_feedforward + default-language: Haskell2010 diff --git a/logs/2018/05/28/155446-32087.txt b/logs/2018/05/28/155446-32087.txt new file mode 100644 index 0000000..3ccf88e --- /dev/null +++ b/logs/2018/05/28/155446-32087.txt @@ -0,0 +1,18 @@ +{"cWhen":1.527504929266068e9,"tag":"Change","cFrom":[0,0],"cText":["d"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,0],"cNewPos":[0,1]} +{"cWhen":1.5275049297637722e9,"tag":"Change","cFrom":[0,0],"cText":[""],"cRemoved":["d"],"cOrigin":"+delete","cTo":[0,1],"cNewPos":[0,0]} +{"cWhen":1.5275049314207401e9,"tag":"Change","cFrom":[0,0],"cText":["s"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,0],"cNewPos":[0,1]} +{"cWhen":1.527504932077358e9,"tag":"Change","cFrom":[0,1],"cText":[" "],"cRemoved":[""],"cOrigin":"+input","cTo":[0,1],"cNewPos":[0,2]} +{"cWhen":1.5275049326979463e9,"tag":"Change","cFrom":[0,2],"cText":["\""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,2],"cNewPos":[0,3]} +{"cWhen":1.5275049334443405e9,"tag":"Change","cFrom":[0,3],"cText":["b"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,3],"cNewPos":[0,4]} +{"cWhen":1.5275049339773788e9,"tag":"Change","cFrom":[0,4],"cText":["d"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,4],"cNewPos":[0,5]} +{"cWhen":1.5275049342661073e9,"tag":"Change","cFrom":[0,5],"cText":["\""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,5],"cNewPos":[0,6]} +{"cWhen":1.5275049345579522e9,"tag":"Change","cFrom":[0,6],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,6],"cNewPos":[1,0]} +{"cWhen":1.5275049353551652e9,"tag":"Change","cFrom":[0,6],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,6]} +{"cWhen":1.5275049361707962e9,"tag":"Change","cFrom":[0,6],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,6],"cNewPos":[1,0]} +{"cWhen":1.5275049372992597e9,"tag":"Change","cFrom":[1,0],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[1,0],"cNewPos":[2,0]} +{"cWhen":1.5275049389184022e9,"tag":"Change","cFrom":[1,0],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[2,0],"cNewPos":[1,0]} +{"cWhen":1.5275049391083975e9,"tag":"Change","cFrom":[0,6],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,6]} +{"cWhen":1.5275049405761473e9,"tag":"Change","cFrom":[0,6],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,6],"cNewPos":[1,0]} +{"cWhen":1.527504941163649e9,"tag":"Change","cFrom":[0,6],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,6]} +{"cWhen":1.5275049420887384e9,"tag":"Change","cFrom":[0,6],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,6],"cNewPos":[1,0]} +{"cWhen":1.5275049429328163e9,"tag":"Change","cFrom":[0,6],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,6]} diff --git a/logs/2018/05/28/155548-32281.txt b/logs/2018/05/28/155548-32281.txt new file mode 100644 index 0000000..6602cb8 --- /dev/null +++ b/logs/2018/05/28/155548-32281.txt @@ -0,0 +1,7 @@ +{"cWhen":1.5275049876225424e9,"tag":"Change","cFrom":[0,0],"cText":["s"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,0],"cNewPos":[0,1]} +{"cWhen":1.5275049888701932e9,"tag":"Change","cFrom":[0,1],"cText":[" "],"cRemoved":[""],"cOrigin":"+input","cTo":[0,1],"cNewPos":[0,2]} +{"cWhen":1.5275049892379236e9,"tag":"Change","cFrom":[0,2],"cText":["\""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,2],"cNewPos":[0,3]} +{"cWhen":1.5275049900308561e9,"tag":"Change","cFrom":[0,3],"cText":["b"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,3],"cNewPos":[0,4]} +{"cWhen":1.527504990330211e9,"tag":"Change","cFrom":[0,4],"cText":["d"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,4],"cNewPos":[0,5]} +{"cWhen":1.5275049906620953e9,"tag":"Change","cFrom":[0,5],"cText":["\""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,5],"cNewPos":[0,6]} +{"cWhen":1.5275049925853126e9,"tag":"Eval"} diff --git a/logs/2018/05/28/181302-14322.txt b/logs/2018/05/28/181302-14322.txt new file mode 100644 index 0000000..2ea4fd4 --- /dev/null +++ b/logs/2018/05/28/181302-14322.txt @@ -0,0 +1,26 @@ +{"cWhen":1.5275131842760983e9,"tag":"Change","cFrom":[0,0],"cText":["s"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,0],"cNewPos":[0,1]} +{"cWhen":1.5275131846285179e9,"tag":"Change","cFrom":[0,1],"cText":["o"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,1],"cNewPos":[0,2]} +{"cWhen":1.5275131852309089e9,"tag":"Change","cFrom":[0,2],"cText":["a"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,2],"cNewPos":[0,3]} +{"cWhen":1.5275131857844613e9,"tag":"Change","cFrom":[0,2],"cText":[""],"cRemoved":["a"],"cOrigin":"+delete","cTo":[0,3],"cNewPos":[0,2]} +{"cWhen":1.5275131860355248e9,"tag":"Change","cFrom":[0,2],"cText":["u"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,2],"cNewPos":[0,3]} +{"cWhen":1.5275131862180932e9,"tag":"Change","cFrom":[0,3],"cText":["n"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,3],"cNewPos":[0,4]} +{"cWhen":1.527513186518804e9,"tag":"Change","cFrom":[0,4],"cText":["d"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,4],"cNewPos":[0,5]} +{"cWhen":1.5275131870315554e9,"tag":"Change","cFrom":[0,5],"cText":[" "],"cRemoved":[""],"cOrigin":"+input","cTo":[0,5],"cNewPos":[0,6]} +{"cWhen":1.5275131874837558e9,"tag":"Change","cFrom":[0,6],"cText":["\""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,6],"cNewPos":[0,7]} +{"cWhen":1.5275131890127006e9,"tag":"Change","cFrom":[0,7],"cText":["b"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,7],"cNewPos":[0,8]} +{"cWhen":1.5275131894982429e9,"tag":"Change","cFrom":[0,8],"cText":["d"],"cRemoved":[""],"cOrigin":"+input","cTo":[0,8],"cNewPos":[0,9]} +{"cWhen":1.5275131898177767e9,"tag":"Change","cFrom":[0,9],"cText":["\""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,9],"cNewPos":[0,10]} +{"cWhen":1.5275131901195118e9,"tag":"Change","cFrom":[0,10],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,10],"cNewPos":[1,0]} +{"cWhen":1.5275131912842221e9,"tag":"Change","cFrom":[0,10],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,10]} +{"cWhen":1.5275131923127484e9,"tag":"Eval"} +{"cWhen":1.5275132082069938e9,"tag":"Change","cFrom":[0,10],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,10],"cNewPos":[1,0]} +{"cWhen":1.5275132100754466e9,"tag":"Change","cFrom":[0,10],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,10]} +{"cWhen":1.5275132125135555e9,"tag":"Eval"} +{"cWhen":1.5275132438884413e9,"tag":"Change","cFrom":[0,10],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,10],"cNewPos":[1,0]} +{"cWhen":1.5275132451633632e9,"tag":"Eval"} +{"cWhen":1.5275132474780948e9,"tag":"Change","cFrom":[0,10],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,10]} +{"cWhen":1.527513248650592e9,"tag":"Eval"} +{"cWhen":1.5275132499021504e9,"tag":"Eval"} +{"cWhen":1.5275132638342712e9,"tag":"Change","cFrom":[0,10],"cText":["",""],"cRemoved":[""],"cOrigin":"+input","cTo":[0,10],"cNewPos":[1,0]} +{"cWhen":1.5275132654541152e9,"tag":"Change","cFrom":[0,10],"cText":[""],"cRemoved":["",""],"cOrigin":"+delete","cTo":[1,0],"cNewPos":[0,10]} +{"cWhen":1.5275132676938472e9,"tag":"Eval"} diff --git a/logs/2018/05/28/181615-14708.txt b/logs/2018/05/28/181615-14708.txt new file mode 100644 index 0000000..e69de29 diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..4c8b60a --- /dev/null +++ b/package.yaml @@ -0,0 +1,29 @@ +name: feedforward + +version: "0.0.1" +copyright: "2018 Author name here" + +executable: + main: Main.hs + source-dirs: + src + +library: + source-dirs: + src + +dependencies: + - aeson + - base + - directory + - filepath + - hint + - hosc + - mtl + - ncurses + - network + - time + - text + - tidal + - websockets + - unix diff --git a/Feedforward/Change.hs b/src/Change.hs similarity index 75% rename from Feedforward/Change.hs rename to src/Change.hs index 2317743..c1970e3 100644 --- a/Feedforward/Change.hs +++ b/src/Change.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} -module Feedforward.Change where +module Change where -import GHC.Generics -import qualified Data.Aeson as A +import qualified Data.Aeson as A +import GHC.Generics {- Fires every time the content of the editor is changed. The changeObj is a {from, to, text, removed, origin} object containing information @@ -19,16 +19,16 @@ an operation, before the DOM updates happen. type Pos = (Int, Int) -data Change = Change {cFrom :: Pos, - cTo :: Pos, - cText :: [String], +data Change = Change {cFrom :: Pos, + cTo :: Pos, + cText :: [String], cRemoved :: [String], - cOrigin :: String, - cWhen :: Double, - cNewPos :: Pos + cOrigin :: String, + cWhen :: Double, + cNewPos :: Pos } | Eval {cWhen :: Double} - | Move {cWhen :: Double, + | Move {cWhen :: Double, cNewPos :: Pos } | Snapshot {cName :: Maybe String, diff --git a/Drum/Client.hs b/src/Client.hs similarity index 53% rename from Drum/Client.hs rename to src/Client.hs index ce0b1b7..d734b14 100644 --- a/Drum/Client.hs +++ b/src/Client.hs @@ -1,26 +1,27 @@ -- Released under terms of GNU Public License version 3 -- (c) Alex McLean 2017 -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} - -module Drum.Client where - -import Control.Exception (try) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Network.WebSockets as WS -import Data.List -import Data.Maybe -import Control.Concurrent -import Control.Concurrent.MVar -import System.Directory -import System.FilePath -import System.IO -import Control.Monad (when) -import Control.Monad.Trans (liftIO) -import Data.Unique -import System.Environment (getArgs,lookupEnv) +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Client where + +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Exception (try) +import Control.Monad (when) +import Control.Monad.Trans (liftIO) +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Unique +import qualified Network.WebSockets as WS +import System.Directory +import System.Environment (getArgs, lookupEnv) +import System.FilePath +import System.IO -- import Data.Ratio -- import System.Process @@ -42,7 +43,7 @@ snapshot snapName conn = putStrLn $ T.unpack msg msg <- WS.receiveData conn putStrLn $ T.unpack msg - + loadSnapshot snapName conn = do WS.sendTextData conn $ T.pack $ "/loadSnapshot " ++ snapName msg <- WS.receiveData conn diff --git a/Feedforward/Edit.hs b/src/Edit.hs similarity index 91% rename from Feedforward/Edit.hs rename to src/Edit.hs index 00aa02e..bae9700 100644 --- a/Feedforward/Edit.hs +++ b/src/Edit.hs @@ -1,60 +1,64 @@ -module Feedforward.Edit where - +module Edit where + {- Feedforward (c) Alex McLean 2018 Text editor for TidalCycles https://github.com/yaxu/feedforward Distributed under the terms of the GNU Public License 3.0, see LICENSE -} -import Control.Concurrent (forkIO, ThreadId, killThread) -import Control.Concurrent.MVar -import Control.Monad (foldM, filterM, forever, when, unless) -import Control.Monad.IO.Class -import Data.Char -import Data.List (intercalate, (\\), elemIndex, inits, sort, isPrefixOf, stripPrefix) -import Data.Maybe (fromMaybe, catMaybes, isJust, fromJust, mapMaybe) -import Data.Time -import Data.Time.Clock.POSIX -import Data.Time.Format -import Sound.OSC.FD -import Sound.Tidal.Context (superDirtSetters, dirtSetters, ParamPattern, cpsUtils, stack, orbit, (#), cpsUtils', silence) -import System.Directory -import System.FilePath -import System.IO -import System.Posix.Process -import System.Posix.Signals -import System.Environment (getArgs,lookupEnv) -import UI.NCurses -import Text.Printf -import qualified Network.Socket as N -import qualified Network.WebSockets as WS -import Data.Text.Lazy.Encoding (decodeUtf8,encodeUtf8) -import Data.Text.Lazy (Text) -import qualified Data.Text.Lazy as T -import qualified Data.Text.IO as T - -import qualified Data.Aeson as A -import GHC.Generics - -import Feedforward.TidalHint -import Feedforward.Change +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Concurrent.MVar +import Control.Monad (filterM, foldM, forever, unless, when) +import Control.Monad.IO.Class +import Data.Char +import Data.List (elemIndex, inits, intercalate, + isPrefixOf, sort, stripPrefix, (\\)) +import Data.Maybe (catMaybes, fromJust, fromMaybe, + isJust, mapMaybe) +import qualified Data.Text.IO as T +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Data.Time +import Data.Time.Clock.POSIX +import Data.Time.Format +import qualified Network.Socket as N +import qualified Network.WebSockets as WS +import Sound.OSC.FD +import Sound.Tidal.Context (ParamPattern, cpsUtils, cpsUtils', + dirtSetters, orbit, silence, stack, + superDirtSetters, ( # )) +import System.Directory +import System.Environment (getArgs, lookupEnv) +import System.FilePath +import System.IO +import System.Posix.Process +import System.Posix.Signals +import Text.Printf +import UI.NCurses + +import qualified Data.Aeson as A +import GHC.Generics + +import Change +import TidalHint type Tag = Int data Status = Success | Error | Normal deriving (Show, Eq) -data Block = Block {bTag :: Tag, +data Block = Block {bTag :: Tag, bModified :: Bool, - bStatus :: Status, - bPattern :: Maybe ParamPattern, - bMute :: Bool, - bSolo :: Bool + bStatus :: Status, + bPattern :: Maybe ParamPattern, + bMute :: Bool, + bSolo :: Bool } deriving Show data Line = Line {lBlock :: Maybe Block, - lText :: String + lText :: String } deriving Show @@ -63,7 +67,7 @@ type Code = [Line] data Dirt = Classic | Super deriving Eq -data Playback = Playback {pbOffset :: Double, +data Playback = Playback {pbOffset :: Double, pbChanges :: [Change] } @@ -79,7 +83,7 @@ lMuted l = fromMaybe False $ bMute <$> lBlock l lMute :: Line -> Bool lMute Line {lBlock = Just Block {bMute = a}} = a -lMute _ = False +lMute _ = False lStatus :: Line -> Maybe Status lStatus l = bStatus <$> lBlock l @@ -101,36 +105,36 @@ type CpsUtils = (Double -> IO (), Double -> IO (), IO Rational) data Mode = EditMode | FileMode | PlaybackMode -data FileChoice = FileChoice {fcPath :: [FilePath], +data FileChoice = FileChoice {fcPath :: [FilePath], fcIndex :: Int, - fcDirs :: [FilePath], + fcDirs :: [FilePath], fcFiles :: [FilePath] } -data State = State {sCode :: Code, - sPos :: Pos, - sXWarp :: Int, - sEditWindow :: Window, - sFileWindow :: Window, - sColour :: ColorID, +data State = State {sCode :: Code, + sPos :: Pos, + sXWarp :: Int, + sEditWindow :: Window, + sFileWindow :: Window, + sColour :: ColorID, sColourHilite :: ColorID, - sColourWarn :: ColorID, + sColourWarn :: ColorID, sColourShaded :: ColorID, - sHintIn :: MVar String, - sHintOut :: MVar Response, - sDirt :: ParamPattern -> IO (), - sChangeSet :: ChangeSet, - sLogFH :: Handle, - sRMS :: [Float], - sScroll :: (Int,Int), - sCpsUtils :: CpsUtils, - sMode :: Mode, - sFileChoice :: FileChoice, - sCircle :: Maybe (Change -> IO ()), - sPlayback :: Maybe Playback, - sName :: Maybe String, - sRefresh :: Bool, - sLastAlt :: Double + sHintIn :: MVar String, + sHintOut :: MVar Response, + sDirt :: ParamPattern -> IO (), + sChangeSet :: ChangeSet, + sLogFH :: Handle, + sRMS :: [Float], + sScroll :: (Int,Int), + sCpsUtils :: CpsUtils, + sMode :: Mode, + sFileChoice :: FileChoice, + sCircle :: Maybe (Change -> IO ()), + sPlayback :: Maybe Playback, + sName :: Maybe String, + sRefresh :: Bool, + sLastAlt :: Double } topMargin = 1 :: Integer @@ -260,7 +264,7 @@ drawFooter :: State -> Curses () drawFooter s = do mc <- maxColor let name = fromMaybe "" ((\x -> "[" ++ x ++ "] ") <$> sName s) - + updateWindow (sEditWindow s) $ do (h,w) <- windowSize moveCursor (h-2) 0 @@ -313,7 +317,7 @@ drawEditor mvS | lStatus l == (Just Error) = setColor $ sColourWarn s | lStatus l == (Just Success) = setAttribute AttributeBold True | otherwise = setColor $ sColour s - + moveCursor y 0 c drawString $ (show $ fromJust (lTag l)) @@ -340,7 +344,7 @@ connectCircle mvS name = do addr <- fromMaybe "127.0.0.1" <$> lookupEnv "CIRCLE_ADDR" port <- fromMaybe "6010" <$> lookupEnv "CIRCLE_PORT" if isJust name - then do mChange <- newEmptyMVar + then do mChange <- newEmptyMVar forkIO $ WS.runClient addr (read port) "/" (app (fromJust name) mChange) return $ Just $ putMVar (mChange :: MVar Change) else (return Nothing) @@ -348,7 +352,7 @@ connectCircle mvS name = do -- hPutStrLn stderr "Connected!" let msg = T.pack $ "/name " ++ name WS.sendTextData conn msg - + forkIO $ forever $ do msg <- WS.receiveData conn circleAct conn $ T.unpack msg @@ -397,7 +401,7 @@ initState args cpsUtils <- liftIO cpsUtils' let setters = case dirt of Classic -> dirtSetters - Super -> superDirtSetters + Super -> superDirtSetters (d, _) <- liftIO (setters getNow) logFH <- liftIO openLog name <- liftIO $ lookupEnv "CIRCLE_NAME" @@ -496,32 +500,32 @@ defaultLogPath = do t <- getZonedTime let i = elemIndex False exists return $ case i of Nothing -> last paths - Just 0 -> [] - Just n -> paths !! (n-1) + Just 0 -> [] + Just n -> paths !! (n-1) pathContents path = do let fullPath = joinPath (logDirectory:path) all <- listDirectory fullPath files <- filterM (doesFileExist . (fullPath )) all dirs <- filterM (doesDirectoryExist . (fullPath )) all return (dirs,files) - + writeLog :: State -> Change -> IO () writeLog s c = do hPutStrLn (sLogFH s) (T.unpack $ decodeUtf8 $ A.encode $ c) hFlush (sLogFH s) sendCircle (sCircle s) - where sendCircle Nothing = return () + where sendCircle Nothing = return () sendCircle (Just f) = f c listenRMS :: MVar State -> IO () listenRMS mvS = do let port = case dirt of - Super -> 0 + Super -> 0 Classic -> 6010 udp <- udpServer "127.0.0.1" port subscribe udp loop udp where - loop udp = + loop udp = do m <- recvMessage udp act m loop udp @@ -651,7 +655,7 @@ handleEv mvS FileMode (Just (EventCharacter x)) liftIO $ putMVar mvS $ s {sMode = EditMode} ok | otherwise = ok - + handleEv mvS FileMode (Just e) = do liftIO $ hPutStrLn stderr $ show e ok fcMove mvS d = do s <- liftIO $ takeMVar mvS @@ -791,7 +795,7 @@ cursorContext' s (y,x) = postL = drop (y+1) ls preX = take x $ lText l postX = drop x $ lText l - + eval :: MVar State -> Curses () eval mvS = @@ -925,7 +929,7 @@ fileMode mvS = do s <- liftIO $ takeMVar mvS liftIO $ putMVar mvS s' drawDirs mvS --- readDir fc +-- readDir fc drawDirs:: MVar State -> Curses () drawDirs mvS @@ -1004,7 +1008,7 @@ selectedPath fc = fcPath fc ++ [selected] where selected = (fcDirs fc ++ fcFiles fc) !! fcIndex fc startPlayback :: State -> FilePath -> IO State -startPlayback s path = +startPlayback s path = do now <- (realToFrac <$> getPOSIXTime) fh <- openFile (logDirectory path) ReadMode c <- hGetContents fh diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..eccc18c --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +import qualified Edit as E + +main = E.main diff --git a/Drum/Server.hs b/src/Server.hs similarity index 85% rename from Drum/Server.hs rename to src/Server.hs index f6b7b16..6255c00 100644 --- a/Drum/Server.hs +++ b/src/Server.hs @@ -1,30 +1,31 @@ -- Released under terms of GNU Public License version 3 -- (c) Alex McLean 2017 -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} - -module Drum.Server where - -import Control.Exception (try) -import Data.Text (Text) -import qualified Data.Text.Lazy as T -import qualified Data.Text.IO as T -import qualified Network.WebSockets as WS -import Data.List -import Data.Maybe -import Control.Concurrent -import Control.Concurrent.MVar -import System.Directory -import System.FilePath -import System.IO -import Control.Monad (when) -import Control.Monad.Trans (liftIO) -import Data.Unique -import qualified Data.Aeson as A -import Data.Text.Lazy.Encoding (decodeUtf8,encodeUtf8) -import qualified Feedforward.Change as C -import Data.Text.Lazy (Text) - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Server where + +import qualified Change as C +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Exception (try) +import Control.Monad (when) +import Control.Monad.Trans (liftIO) +import qualified Data.Aeson as A +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text.IO as T +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8) +import Data.Unique +import qualified Network.WebSockets as WS +import System.Directory +import System.FilePath +import System.IO + -- import Data.Ratio -- import System.Process -- import Data.Time.Clock.POSIX @@ -35,12 +36,12 @@ import Data.Text.Lazy (Text) port = 6010 -data Client = Client {cName :: String, +data Client = Client {cName :: String, cServerThread :: ThreadId, - cSender :: String -> IO (), - cFN :: Maybe String, - cConn :: WS.Connection, - cId :: Unique + cSender :: String -> IO (), + cFN :: Maybe String, + cConn :: WS.Connection, + cId :: Unique } wsSend :: WS.Connection -> IO (ThreadId, String -> IO()) @@ -65,7 +66,7 @@ run = do (senderThreadId, sender) <- wsSend conn sender $ "/welcome" - + WS.forkPingThread conn 30 uniqueId <- liftIO newUnique let client = Client {cName = "anonymous", @@ -201,6 +202,6 @@ act_loadSnapshot param mClients client conn = where checkChange :: Maybe C.Change -> Maybe C.Change checkChange (Just c@(C.Snapshot {C.cName = Just snapName'})) | snapName == snapName' = Just $ c {C.cWhen = -1} checkChange _ = Nothing - + diff --git a/Feedforward/TidalHint.hs b/src/TidalHint.hs similarity index 90% rename from Feedforward/TidalHint.hs rename to src/TidalHint.hs index 31b24a4..13de59b 100644 --- a/Feedforward/TidalHint.hs +++ b/src/TidalHint.hs @@ -1,16 +1,16 @@ -module Feedforward.TidalHint where +module TidalHint where -import Sound.Tidal.Context -import System.IO -import System.Posix.Signals -import Language.Haskell.Interpreter as Hint -import Control.Exception +import Control.Exception +import Language.Haskell.Interpreter as Hint +import Sound.Tidal.Context +import System.IO +import System.Posix.Signals data Response = HintOK {parsed :: ParamPattern} | HintError {errorMessage :: String} instance Show Response where - show (HintOK p) = "Ok: " ++ show p + show (HintOK p) = "Ok: " ++ show p show (HintError s) = "Error: " ++ s {- @@ -51,7 +51,7 @@ hintJob (mIn, mOut) = (\e -> return (Left $ UnknownError $ "exception" ++ show (e :: SomeException))) let response = case result of Left err -> HintError (parseError err) - Right p -> HintOK p -- can happen + Right p -> HintOK p -- can happen parseError (UnknownError s) = "Unknown error: " ++ s parseError (WontCompile es) = "Compile error: " ++ (intercalate "\n" (Prelude.map errMsg es)) parseError (NotAllowed s) = "NotAllowed error: " ++ s diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..4fb2e99 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,68 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# resolver: +# name: custom-snapshot +# location: "./custom-snapshot.yaml" +resolver: lts-11.11 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-dep: true +# subdirs: +# - auto-update +# - wai +# +# A package marked 'extra-dep: true' will only be built if demanded by a +# non-dependency (i.e. a user package), and its test suites and benchmarks +# will not be run. This is useful for tweaking upstream packages. +packages: +- . + +# Dependency packages to be pulled from upstream that are not in the resolver +# (e.g., acme-missiles-0.3) +extra-deps: +- ncurses-0.2.16 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.6" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor