update spec to support normal io pins

[mTask.git] / Devices / mTaskDevice.icl

diff --git a/Devices/mTaskDevice.icl b/Devices/mTaskDevice.icl
index 9a93634..a91a0b3 100644 (file)
--- a/Devices/mTaskDevice.icl
+++ b/Devices/mTaskDevice.icl
@@ -1,26 +1,41 @@
 implementation module Devices.mTaskDevice
 
 implementation module Devices.mTaskDevice
 

+from StdFunc import flip

 import Generics.gCons
 import mTaskInterpret
 import iTasks
 import iTasksTTY
 import TTY
 import qualified Data.Map as DM
 import Generics.gCons
 import mTaskInterpret
 import iTasks
 import iTasksTTY
 import TTY
 import qualified Data.Map as DM

+import qualified Data.List as DL

 import Utils.SDS
 import Utils.SDS

+import Utils.Devices

 
 import GenBimap
 import Devices.mTaskSerial
 import Devices.mTaskTCP
 
 import GenBimap
 import Devices.mTaskSerial
 import Devices.mTaskTCP

+import Data.Tuple

 import iTasks._Framework.Store
 import iTasks._Framework.Store

+import iTasks.UI.Definition, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Common, iTasks.UI.Layout.Default, iTasks.UI.Layout.Common

 
 from Data.Func import $
 
 
 from Data.Func import $
 

-derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend
+derive class iTask MTaskDevice, MTaskResource, MTaskMSGRecv, MTaskMSGSend, BCShare

 derive conses MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
 derive consName MTaskResource, TTYSettings, BaudRate, Parity, ByteSize, TCPSettings
 
 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)
+instance == MTaskDevice where
+       (==) a b = a.deviceChannels == b.deviceChannels
+
+startupDevices :: Task [MTaskDevice]
+startupDevices = upd (map reset) deviceStoreNP
+       where reset d = {d & deviceTask=Nothing, deviceTasks=[], deviceError=Nothing}
+
+withDevice :: (MTaskDevice -> Task a) String -> Task a | iTask a
+withDevice f s = get deviceStoreNP
+       >>= \ds->case 'DL'.find (\d->d.deviceName == s) ds of
+               Nothing = throw "Device not available"
+               Just d = f d

 
 makeDevice :: String MTaskResource -> Task MTaskDevice
 makeDevice name res = get randomInt @ \rand->{MTaskDevice
 
 makeDevice :: String MTaskResource -> Task MTaskDevice
 makeDevice name res = get randomInt @ \rand->{MTaskDevice


@@ -28,83 +43,105 @@ makeDevice name res = get randomInt @ \rand->{MTaskDevice
                ,deviceName=name
                ,deviceTasks=[]
                ,deviceTask=Nothing
                ,deviceName=name
                ,deviceTasks=[]
                ,deviceTask=Nothing

-               ,deviceData=res}
+               ,deviceError=Nothing
+               ,deviceState=zero
+               ,deviceData=res
+               ,deviceSpec=Nothing
+               ,deviceShares=[]}

 
 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
 getSynFun (TCPDevice t) = synFun t
 getSynFun (SerialDevice t) = synFun t
 
 
 getSynFun :: MTaskResource -> ((Shared Channels) -> Task ())
 getSynFun (TCPDevice t) = synFun t
 getSynFun (SerialDevice t) = synFun t
 

-addDevice :: (Shared [MTaskDevice]) (MTaskDevice (Shared Channels) -> Task ()) -> Task String
-addDevice devices processFun
+addDevice :: (MTaskDevice (Shared Channels) -> Task ()) -> Task String
+addDevice processFun

        =   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
        =   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 (tlt dev)
-                       >>= \tid->upd (\l->[{dev & deviceTask=Just tid}:l]) devices
+                       >>= \dev->traceValue "make device done"
+                       >>| upd (\l->[dev:l]) deviceStoreNP
+                       >>| traceValue "update deviceslist"
+                       >>| connectDevice processFun dev
+                       >>| traceValue "device connected"

                        @! ""
        where
                        @! ""
        where

-               tlt dev = let ch = channels dev in processFun dev ch -||- getSynFun dev.deviceData ch
-

                deviceSettings "SerialDevice" = getmTaskSerialDevice
                deviceSettings "TCPDevice" = getmTaskTCPDevice
 
                deviceTypes :: [MTaskResource]
                deviceTypes = conses{|*|}
 
                deviceSettings "SerialDevice" = getmTaskSerialDevice
                deviceSettings "TCPDevice" = getmTaskTCPDevice
 
                deviceTypes :: [MTaskResource]
                deviceTypes = conses{|*|}
 

-manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) [MTaskDevice] -> Task ()
-manageDevices processFun ds = anyTask [
-               addDevice deviceStore processFun <<@ Title "Add new device" @! ():
-                       [viewDevice d <<@ Title d.deviceName\\d<-ds]]
-       <<@ ArrangeWithTabs @! ()
+//connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
+//connectDevice pf d = let ch = channels d in appendTopLevelTask 'DM'.newMap True
+//     (pf d ch -||- catchAll (getSynFun d.deviceData ch) errorHandle)
+//     >>= \tid->withDevices d (\d->{d&deviceTask=Just tid,deviceError=Nothing})
+//     >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
+//     @! ()
+//     where
+//             errorHandle e = withDevices d (\d->{d&deviceTask=Nothing,deviceError=Just e}) @! ()
+import StdDebug
+connectDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task Channels
+connectDevice procFun device = let ch = channels device
+       in traceValue "connectDevice" >>| appendTopLevelTask 'DM'.newMap True
+               (       procFun device ch -||- catchAll (getSynFun device.deviceData ch) errHdl)
+               >>= \tid->withDevices device (\d->{d&deviceTask=Just tid,deviceError=Nothing})
+               >>| upd (\(r,s,ss)->(r,s++[MTSpec],ss)) ch
+       where
+               errHdl e
+               | not (trace_tn "error") = undef
+               = withDevices device (\d->{d & deviceTask=Nothing, deviceError=Just e}) @! ()
+
+manageDevices :: (MTaskDevice (Shared Channels) -> Task ()) -> Task ()
+manageDevices processFun = get deviceStoreNP >>= \ds->anyTask [
+               addDevice processFun <<@ Title "Add new device" @! ()]//:
+//                     [viewDevice processFun d <<@ Title d.deviceName\\d<-ds]]
+       <<@ ArrangeWithTabs
+       @! ()

 
 

-viewDevice :: MTaskDevice -> Task ()
-viewDevice d = anyTask 
+viewDevice :: (MTaskDevice (Shared Channels) -> Task ()) MTaskDevice -> Task ()
+viewDevice pf d = forever $ traceValue "viewDevice" >>| anyTask 

                [viewInformation "Device settings" [] d @! ()
                [viewInformation "Device settings" [] d @! ()

-               ,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()
+               /*,viewSharedInformation "Channels" [ViewAs dropEmpty] (channels d) @! ()*/

                ,forever $ 
                        enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
                        >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
                        @! ()
                ] <<@ ArrangeHorizontal
                ,forever $ 
                        enterChoice "Delete task on device" [ChooseFromGrid id] d.deviceTasks
                        >>* [OnAction (Action "Delete") $ ifValue (\t->t.ident <> -1) (deviceTaskDelete d)]
                        @! ()
                ] <<@ ArrangeHorizontal

+               >>* [OnAction (Action "Delete Device") (always $ deleteDevice d):
+                               if (isJust d.deviceTask) []
+                               [OnAction (Action "Connect") (always $ connectDevice pf d @! ())]]

        where
                dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 
        where
                dropEmpty (r,s,ss) = (filter ((=!=)MTEmpty) r,s,ss)
 

-sendToDevice :: String (Main (ByteCode () Stmt)) (MTaskDevice, Int) -> Task ()
-sendToDevice wta mTask (device, timeout) =
-               get bcStateStore
-       >>= \st->treturn (toMessages timeout (toRealByteCode (unMain mTask) st))
-       >>= \(msgs, st1)->set st1 bcStateStore @ toSDSRecords
-       >>= \sdss->upd ((++)sdss) sdsStore//MTaskShareaddToSDSShare
-       >>| makeShares sdss
-       >>| sendMessage device msgs
-       >>| makeTask wta -1
-       >>= \task->withDevices device (addTask timeout task)
+deleteDevice :: MTaskDevice -> Task ()
+deleteDevice d = sendMessages [MTShutdown] d
+       >>| wait "Waiting for the channels to empty" (\(r,s,ss)->isEmpty s) (channels d)
+       >>| upd (\(r,s,ss)->(r,s,True)) (channels d)
+       >>| maybe (treturn ()) (flip removeTask topLevelTasks) d.deviceTask
+       >>| upd (filter ((<>)d)) deviceStoreNP
+//     >>| cleanSharesDevice d.deviceName

        @! ()
        @! ()

-       where
-               sharename i = device.deviceChannels +++ "-" +++ toString i
-               toSDSRecords st = [{MTaskShare |
-                       initValue=toInt d1*265 + toInt d2,
-                       withTask=wta,
-                       identifier=i,
-                       realShare="mTaskSDS-" +++ toString i}
-                               \\(i,[d1,d2])<-st.sdss]
-               makeShares = foldr (\sh t->set sh.initValue (getSDSStore sh) >>| t) (treturn ())
-
-               addTask :: Int MTaskTask MTaskDevice -> MTaskDevice
-               addTask timeout task device = {device & deviceTasks=[task:device.deviceTasks]}
-
-sendMessage :: MTaskDevice [MTaskMSGSend] -> Task ()
-sendMessage dev msgs = upd (\(r,s,ss)->(r,msgs++s,ss)) (channels dev) @! ()
-
-withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task ()
-withDevices a trans = upd (map withDevice) deviceStore @! ()
-       where withDevice b = if (a.deviceChannels == b.deviceChannels) (trans b) b
-
-deviceTaskAcked :: MTaskDevice Int -> Task ()
-deviceTaskAcked dev i 
-       = withDevices dev (\d->{d&deviceTasks=ackFirst d.deviceTasks})
+
+sendMessages :: [MTaskMSGSend] MTaskDevice -> Task Channels
+sendMessages msgs dev = upd (realMessageSend msgs) $ channels dev
+
+sendMessagesIW :: [MTaskMSGSend] MTaskDevice *IWorld -> *(MaybeError TaskException (), *IWorld)
+sendMessagesIW msgs dev iworld 
+       = modify (tuple () o realMessageSend msgs) (channels dev) iworld
+
+realMessageSend :: [MTaskMSGSend] Channels -> Channels
+realMessageSend msgs (r,s,ss) = (r,msgs++s,ss)
+
+withDevices :: MTaskDevice (MTaskDevice -> MTaskDevice) -> Task [MTaskDevice]
+withDevices a trans = upd (map \b->if (b == a) (trans b) b) deviceStoreNP
+
+deviceTaskAcked :: MTaskDevice Int Int -> Task [MTaskDevice]
+deviceTaskAcked dev i mem
+       = withDevices dev (\d->{d
+                       &deviceTasks=ackFirst d.deviceTasks
+                       ,deviceSpec=Just {fromJust d.deviceSpec & bytesMemory=mem}})

        where
                ackFirst :: [MTaskTask] -> [MTaskTask]
                ackFirst [] = []
        where
                ackFirst :: [MTaskTask] -> [MTaskTask]
                ackFirst [] = []


@@ -112,8 +149,12 @@ deviceTaskAcked dev i
                        [{t & ident=i}:ts] [t:ackFirst ts]
 
 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()
                        [{t & ident=i}:ts] [t:ackFirst ts]
 
 deviceTaskDelete :: MTaskDevice MTaskTask -> Task ()

-deviceTaskDelete dev task = sendMessage dev [MTTaskDel task.ident]
+deviceTaskDelete dev task = sendMessages [MTTaskDel task.ident] dev @! ()

 
 

-deviceTaskDeleteAcked :: MTaskDevice Int -> Task ()
-deviceTaskDeleteAcked d i = withDevices d $ deleteTask
+deviceTaskDeleteAcked :: MTaskDevice Int -> Task [MTaskDevice]
+deviceTaskDeleteAcked d i = cleanSharesTask i d
+       >>| withDevices d deleteTask

        where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}
        where deleteTask d = {d & deviceTasks=[s\\s<-d.deviceTasks | i <> s.ident]}

+
+deviceAddSpec :: MTaskDevice MTaskDeviceSpec -> Task [MTaskDevice]
+deviceAddSpec d s = withDevices d $ \r->{MTaskDevice | r & deviceSpec=Just s}