From: Mart Lubbers Date: Sun, 26 Feb 2017 12:37:31 +0000 (+0100) Subject: modularize X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=00fec1dc0792381759d7cfbfb55f17996a11f1a4;p=mTask.git modularize --- diff --git a/Devices/mTaskDevice.dcl b/Devices/mTaskDevice.dcl new file mode 100644 index 0000000..6551eb3 --- /dev/null +++ b/Devices/mTaskDevice.dcl @@ -0,0 +1,38 @@ +definition module Devices.mTaskDevice + +from Data.Maybe import :: Maybe +import iTasks +import Devices.mTaskSerial +import Devices.mTaskTCP +import mTaskInterpret +import Generics.gCons +import iTasksTTY + +derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend +derive conses MTaskResource, TCPSettings +derive consName MTaskResource, TCPSettings + +channels :: MTaskDevice -> Shared Channels + +:: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool) + +:: MTaskResource + = TCPDevice TCPSettings + | SerialDevice TTYSettings + +:: MTaskDevice = { + deviceTask :: Maybe TaskId + ,deviceChannels :: String + ,deviceName :: String + ,deviceTasks :: [(String, Int)] + ,deviceData :: MTaskResource + } + +class MTaskDuplex a where + synFun :: a (Shared Channels) -> Task () + +//makeDevice :: MTaskResource String -> Task MTaskDevice + +addDevice :: (Shared [MTaskDevice]) -> Task String +//addDevice :: (Shared [MTaskDevice]) -> Task MTaskResource +//addDevice :: (Shared [MTaskDevice]) -> Task () diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl new file mode 100644 index 0000000..2bd7121 --- /dev/null +++ b/Devices/mTaskDevice.icl @@ -0,0 +1,51 @@ +implementation module Devices.mTaskDevice + +import Generics.gCons +import mTaskInterpret +import iTasks +import iTasksTTY +import TTY +import qualified Data.Map as DM +import Utils + +import GenBimap +import Devices.mTaskSerial +import Devices.mTaskTCP +import iTasks._Framework.Store + +from Data.Func import $ + +derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend +derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings +derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings + +channels :: MTaskDevice -> Shared Channels +channels d = memoryShare d.deviceChannels ([], [], False) + +makeDevice :: String MTaskResource -> Task MTaskDevice +makeDevice name res = get randomInt @ \rand->{MTaskDevice + |deviceChannels=name +++ toString rand + ,deviceName=name + ,deviceTasks=[] + ,deviceTask=Nothing + ,deviceData=res} + +getSynFun :: MTaskResource -> ((Shared Channels) -> Task ()) +getSynFun (TCPDevice t) = synFun t +getSynFun (SerialDevice t) = synFun t + +addDevice :: (Shared [MTaskDevice]) -> Task String +addDevice devices = enterChoice "Device type" [] (map consName{|*|} deviceTypes) + >&^ \sh->whileUnchanged sh $ \mty->case mty of + Nothing = viewInformation "No type selected yet" [] "" + Just ty = enterInformation "Name" [] -&&- deviceSettings ty + >>= \(name, settings)->makeDevice name settings + >>= \dev->appendTopLevelTask 'DM'.newMap True (let ch=channels dev in getSynFun dev.deviceData ch) + >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices + @! "" + where + deviceSettings "SerialDevice" = getmTaskSerialDevice + deviceSettings "TCPDevice" = getmTaskTCPDevice + +deviceTypes :: [MTaskResource] +deviceTypes = conses{|*|} diff --git a/Devices/mTaskSerial.dcl b/Devices/mTaskSerial.dcl new file mode 100644 index 0000000..0696979 --- /dev/null +++ b/Devices/mTaskSerial.dcl @@ -0,0 +1,8 @@ +definition module Devices.mTaskSerial + +import Devices.mTaskDevice +import iTasks + +getmTaskSerialDevice :: Task MTaskResource + +instance MTaskDuplex TTYSettings diff --git a/Devices/mTaskSerial.icl b/Devices/mTaskSerial.icl new file mode 100644 index 0000000..59f86b4 --- /dev/null +++ b/Devices/mTaskSerial.icl @@ -0,0 +1,12 @@ +implementation module Devices.mTaskSerial + +import Devices.mTaskDevice +import TTY +import iTasks + +getmTaskSerialDevice :: Task MTaskResource +getmTaskSerialDevice = SerialDevice <$> enterTTYSettings + +instance MTaskDuplex TTYSettings where + synFun :: TTYSettings (Shared Channels) -> Task () + synFun settings channels = syncSerialChannel settings encode decode channels diff --git a/Devices/mTaskTCP.dcl b/Devices/mTaskTCP.dcl new file mode 100644 index 0000000..627fedf --- /dev/null +++ b/Devices/mTaskTCP.dcl @@ -0,0 +1,10 @@ +definition module Devices.mTaskTCP + +import Devices.mTaskDevice +import iTasks + +:: TCPSettings = {host :: String, port :: Int} +derive class iTask TCPSettings + +getmTaskTCPDevice :: Task MTaskResource +instance MTaskDuplex TCPSettings diff --git a/Devices/mTaskTCP.icl b/Devices/mTaskTCP.icl new file mode 100644 index 0000000..bf05e05 --- /dev/null +++ b/Devices/mTaskTCP.icl @@ -0,0 +1,28 @@ +implementation module Devices.mTaskTCP + +import Devices.mTaskDevice +import iTasks + +derive class iTask TCPSettings + +getmTaskTCPDevice :: Task MTaskResource +getmTaskTCPDevice = TCPDevice <$> enterInformation "Settings" [] + +instance MTaskDuplex TCPSettings where + synFun :: TCPSettings (Shared Channels) -> Task () + synFun s channels = catchAll ( + tcpconnect s.host s.port channels {ConnectionHandlers| + onConnect=onConnect, + whileConnected=whileConnected, + onDisconnect=onDisconnect} @! ()) + (\v->traceValue v @! ()) + where + onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool) + onConnect _ (msgs,send,sendStopped) = (Ok "", Just (msgs,[],sendStopped), map encode send, False) + + whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool) + whileConnected Nothing acc (msgs,send,sendStopped) = (Ok acc, Nothing, [], False) + whileConnected (Just newData) acc (msgs,send,sendStopped) = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False) + + onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool)) + onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing) diff --git a/Generics/gCons.dcl b/Generics/gCons.dcl index 7877e11..ad99042 100644 --- a/Generics/gCons.dcl +++ b/Generics/gCons.dcl @@ -10,10 +10,10 @@ definition module Generics.gCons import StdGeneric generic consName a :: a -> String -derive consName CONS of {gcd_name},UNIT,PAIR,EITHER,OBJECT,RECORD,FIELD,Int,Bool,Char,String,(->),[] +derive consName CONS of {gcd_name},UNIT,PAIR,EITHER,OBJECT,RECORD,FIELD,Int,Bool,Char,String,(),(,),(,,),(,,,),(,,,,),(->),[] generic consIndex a :: a -> Int -derive consIndex CONS of {gcd_index},UNIT,PAIR,EITHER,OBJECT,Int,Bool,Char,String,[] +derive consIndex CONS of {gcd_index},UNIT,PAIR,EITHER,OBJECT,Int,Bool,Char,String,(),(,),(,,),(,,,),(,,,,),[] generic conses a :: [a] -derive conses CONS,UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bool,Char,Real,String,(),{},{!},[],[! ],[ !],[!!],(->) +derive conses CONS,UNIT,PAIR,EITHER,OBJECT,FIELD,RECORD,Int,Bool,Char,Real,String,(),(,),(,,),(,,,),(,,,,),{},{!},[],[! ],[ !],[!!],(->) diff --git a/Generics/gCons.icl b/Generics/gCons.icl index fc4debc..6f0ceb3 100644 --- a/Generics/gCons.icl +++ b/Generics/gCons.icl @@ -8,6 +8,7 @@ implementation module Generics.gCons */ import StdEnv, StdGeneric, GenBimap, _SystemStrictLists +import Data.List generic consName a :: a -> String consName{|CONS of {gcd_name}|} f x = gcd_name @@ -23,6 +24,11 @@ consName{|Bool|} b = toString b consName{|Char|} c = toString c consName{|String|} s = s consName{|[]|} _ _ = "[]" +consName{|()|} _ = "()" +consName{|(,)|} _ _ _ = "(,)" +consName{|(,,)|} _ _ _ _ = "(,,)" +consName{|(,,,)|} _ _ _ _ _ = "(,,,)" +consName{|(,,,,)|} _ _ _ _ _ _ = "(,,,,)" consName{|(->)|} f g x = g (x undef) generic consIndex a :: a -> Int @@ -37,6 +43,11 @@ consIndex{|Bool|} b = if b 1 0 consIndex{|Char|} c = toInt c consIndex{|String|} _ = 0 consIndex{|[]|} _ _ = 0 +consIndex{|()|} _ = 0 +consIndex{|(,)|} _ _ _ = 0 +consIndex{|(,,)|} _ _ _ _ = 0 +consIndex{|(,,,)|} _ _ _ _ _ = 0 +consIndex{|(,,,,)|} _ _ _ _ _ _ = 0 generic conses a :: [a] conses{|CONS|} f = [CONS (hd f)] @@ -55,7 +66,11 @@ conses{|[]|} _ = [[ ]] conses{|[!]|} _ = [[!]] conses{|[ !]|} _ = [[ !]] conses{|[!!]|} _ = [[!!]] +conses{|()|} = [()] +conses{|(,)|} f g = zip2 f g +conses{|(,,)|} f g h = zip3 f g h +conses{|(,,,)|} f g h i = zip4 f g h i +conses{|(,,,,)|} f g h i j = zip5 f g h i j conses{|{}|} _ = [{}] conses{|{!}|} _ = [{!}] -conses{|()|} = [()] conses{|(->)|} _ _ = [const undef] diff --git a/Makefile b/Makefile index e0d65c9..7b0fe31 100644 --- a/Makefile +++ b/Makefile @@ -31,7 +31,7 @@ CleanSerial/Clean\ System\ Files/TTY.o: client/mTaskSymbols.h: mTaskMakeSymbols ./$< -nr > $@ -%: %.icl $(wildcard *.[id]cl) +%: %.icl $(wildcard */*.[id]cl *.[id]cl) $(CLM) $(CLMLIBS) $(CLMFLAGS) $(basename $<) -o $@ clean: diff --git a/Utils.dcl b/Utils.dcl new file mode 100644 index 0000000..cda8a7a --- /dev/null +++ b/Utils.dcl @@ -0,0 +1,5 @@ +definition module Utils + +import iTasks + +memoryShare :: String a -> Shared a | iTask a diff --git a/Utils.icl b/Utils.icl new file mode 100644 index 0000000..3a9be2c --- /dev/null +++ b/Utils.icl @@ -0,0 +1,8 @@ +implementation module Utils + +import iTasks +import iTasks._Framework.Store +from Data.Func import $ + +memoryShare :: String a -> Shared a | iTask a +memoryShare s d = sdsFocus s $ memoryStore "" $ Just d diff --git a/miTask.icl b/miTask.icl index 81c765b..6c80f05 100644 --- a/miTask.icl +++ b/miTask.icl @@ -5,6 +5,7 @@ from StdFunc import flip import iTasks import mTask +import Devices.mTaskDevice from Text import class Text(startsWith,concat,split,join), instance Text String @@ -19,18 +20,8 @@ import iTasks._Framework.Store import TTY, iTasksTTY -derive class iTask MTaskMSGRecv, MTaskMSGSend, SerTCP, UserLED +derive class iTask UserLED -:: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool) - -:: SerTCP = SerialDevice | TCPDevice -:: MTaskDevice = { - deviceTask :: Maybe TaskId - ,deviceChannels :: String - ,deviceName :: String - ,deviceTasks :: [(String, Int)] -// ,deviceSyncfun :: (Shared Channels) -> Task () - } :: MTaskShare = { initValue :: Int, withTask :: String, @@ -85,7 +76,7 @@ bc3 :: UserLED -> Main (ByteCode () Stmt) bc3 d = {main = ledOff d} :: MTaskDeviceStatus = {connected :: Bool, name :: String, tasks :: [String]} -derive class iTask MTaskDeviceStatus, MTaskDevice, MTaskShare, BCState +derive class iTask MTaskDeviceStatus, MTaskShare, BCState mTaskManager :: Task () mTaskManager = anyTask @@ -140,9 +131,6 @@ mTaskManager = anyTask getSDSRecord :: Int -> Task MTaskShare getSDSRecord i = get sdsStore @ \l->hd [s\\s<-l | s.identifier == i] - channels :: MTaskDevice -> Shared Channels - channels d = memoryShare d.deviceChannels ([], [], False) - viewShares :: [MTaskShare] -> Task () viewShares st = anyTask $ map viewer st where @@ -172,26 +160,6 @@ mTaskManager = anyTask where dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss) - addDevice :: (Shared [MTaskDevice]) -> Task SerTCP - addDevice devices = enterInformation "Device type" [] - >&^ \sh->whileUnchanged sh $ \mty->case mty of - Nothing = viewInformation "No type selected yet" [] "" @! () - Just ty = case ty of - TCPDevice = (enterInformation "Name" [] -&&- enterInformation "Hostname" [] -&&- enterInformation "Port" []) - >>= \(name, (host, port))->cont name (syncNetworkChannel host port) - SerialDevice = (enterInformation "Name" [] -&&- enterTTYSettings) - >>= \(name, set)->cont name (syncSerialChannel set encode decode) - where - cont :: String ((Shared Channels) -> Task ()) -> Task () - cont name synfun = get randomInt - @ (\randint->{MTaskDevice | - deviceChannels=name +++ toString randint, - deviceName=name, - deviceTasks=[], - deviceTask=Nothing}) - >>= \dev->appendTopLevelTask 'DM'.newMap True (let ch = channels dev in process ch -||- synfun ch) - >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices - @! () // addDevice :: (Shared [MTaskDevice]) -> Task SerTCP // addDevice devices = enterInformation "Device type" [] diff --git a/miTaskDevices.dcl b/miTaskDevices.dcl deleted file mode 100644 index 05aca62..0000000 --- a/miTaskDevices.dcl +++ /dev/null @@ -1,21 +0,0 @@ -definition module miTaskDevices - -import mTask -import iTasks -import iTasksTTY - -:: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool) -:: TCPDevice = {hostname :: String, port :: Int} -:: SerialDevice = {settings :: TTYSettings} - -derive class iTask TCPDevice, SerialDevice - -getmTaskDevice :: Task a | mTaskDevice a - -class mTaskDevice a where - syncTask :: a (Shared Channels) -> Task () - entermTaskDevice :: Task a - viewmTaskDevice :: a -> Task a - -instance mTaskDevice TCPDevice -instance mTaskDevice SerialDevice diff --git a/miTaskDevices.icl b/miTaskDevices.icl deleted file mode 100644 index 1a0b3eb..0000000 --- a/miTaskDevices.icl +++ /dev/null @@ -1,50 +0,0 @@ -implementation module miTaskDevices - -import mTask -import iTasks - -:: Channels :== ([MTaskMSGRecv], [MTaskMSGSend], Bool) -:: TCPDevice = {hostname :: String, port :: Int} -:: SerialDevice = {settings :: TTYSettings} - -:: DeviceType = SerialDevice | TCPDevice - -derive class iTask TCPDevice, SerialDevice, DeviceType - -getmTaskDevice :: Task a | mTaskDevice a -getmTaskDevice = enterInformation "Device type" [] - >&^ \st->whileUnchanged st $ \dt->case dt of - Nothing = viewInformation "No type selected yet" [] Nothing - Just SerialDevice = getSerialDevice @ pure - Just TCPDevice = getTDevice @ pure - >>* [OnValue (ifValue isJust fromJust)] - where - getSD :: Task SerialDevice - getSD = entermTaskDevice - getTD :: Task TCPDevice - getTD = entermTaskDevice - -instance mTaskDevice TCPDevice where - entermTaskDevice = enterInformation "" [] - viewmTaskDevice = viewInformation "" [] - syncTask d ch = catchAll ( - tcpconnect d.host d.port ch {ConnectionHandlers| - onConnect=onConnect, - whileConnected=whileConnected, - onDisconnect=onDisconnect} @! ()) - (\v->traceValue v @! ()) - where - onConnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool) - onConnect _ (msgs,send,sendStopped) = (Ok "", Just (msgs,[],sendStopped), map encode send, False) - - whileConnected :: (Maybe String) String ([MTaskMSGRecv], [MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool), [String], Bool) - whileConnected Nothing acc (msgs,send,sendStopped) = (Ok acc, Nothing, [], False) - whileConnected (Just newData) acc (msgs,send,sendStopped) = (Ok acc, Just (msgs ++ [decode newData],[],False), map encode send, False) - - onDisconnect :: String ([MTaskMSGRecv],[MTaskMSGSend],Bool) -> (MaybeErrorString String, Maybe ([MTaskMSGRecv],[MTaskMSGSend],Bool)) - onDisconnect l (msgs,send,sendStopped) = (Ok l, Nothing) - -instance mTaskDevice SerialDevice where - entermTaskDevice = enterTTYSettings >>= \s->{SerialDevice|settings=s} - viewmTaskDevice = viewInformation "" [] - syncTask d ch = syncSerialSettings d.settings encode decode ch