Finally compiles. Large refactor. Unstable

Auto.hs

@@ -1,22 +1,21 @@
 module Auto where
 
-import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
+import Control.Monad.Reader (Reader, runReader, asks)
 import Control.Applicative ((<$>))
 import qualified Data.Map as M
+import Types
 
-type Env a = (M.Map String a)
 
-
-envLookup :: (Show a) => String -> Auto a a
+envLookup :: String -> Auto Parameter
 envLookup key = do
-    maybeVal <- M.lookup key <$> ask
+    maybeVal <- M.lookup key <$> asks envC
     case maybeVal of
         Just v -> return v
         Nothing -> error $ "Undefined environment variable: " ++ key
 
 
-type Auto a = ReaderT (Env a) IO
+type Auto = Reader Config
 
 
-runAuto :: Auto a b -> Env a -> IO b
-runAuto = runReaderT
+runAuto :: Auto a -> Config -> a
+runAuto = runReader

CCSDS.hs

@@ -6,9 +6,11 @@ module CCSDS where
 import Data.BitVector
 import Control.Exception.Base (assert)
 import Control.Applicative ((<$>))
+import qualified Data.ByteString.Lazy as B
 import Common
 import Parameter
 import Auto
+import Types
 
 
 packetVersionNumber :: BV
@@ -27,7 +29,7 @@ sequenceCount :: BV
 sequenceCount = zeros 14
 
 
-packetDataLength :: (CCSDS a) => a -> Auto Parameter BV
+packetDataLength :: (CCSDS a) => a -> Auto BV
 packetDataLength m = do
     pl <- length <$> payload m
     return . bitVec 16 $ length (secondaryHeader m) + pl
@@ -41,11 +43,11 @@ class (Show a) => CCSDS a where
 
     secondaryHeader :: a -> [Byte]
 
-    payload :: a -> Auto Parameter [Byte]
+    payload :: a -> Auto [Byte]
 
 
 
-primaryHeader :: (CCSDS a) => a -> Auto Parameter BV
+primaryHeader :: (CCSDS a) => a -> Auto BV
 primaryHeader m = do
     dataLength <- packetDataLength m
     return $ packetVersionNumber
@@ -57,20 +59,20 @@ primaryHeader m = do
              # dataLength
 
 
-header :: (CCSDS a) => a -> Auto Parameter [Byte]
+header :: (CCSDS a) => a -> Auto [Byte]
 header m = do
     pri <- bits2bytes . toBits <$> primaryHeader m
     return $ pri ++ secondaryHeader m
 
 
-packet :: (CCSDS a) => a -> Auto Parameter [Byte]
+packet :: (CCSDS a) => a -> Auto [Byte]
 packet m = do
     p <- payload m
     h <- swapBytes <$> header m
     return $ h ++ p
 
 
-packCCSDS :: (CCSDS a) => a -> Auto Parameter [Byte]
+packCCSDS :: (CCSDS a) => a -> Auto B.ByteString
 packCCSDS m = do
     p <- packet m
     pri <- primaryHeader m
@@ -79,4 +81,4 @@ packCCSDS m = do
     let check1 = size pri == 6 * 8 --bits
     let check2 = length pld + length (secondaryHeader m) == len + 1
     let checkAll = check1 -- && check2
-    return $ assert checkAll p
+    return $ assert checkAll (B.pack p)

Command.hs

@@ -7,22 +7,13 @@ module Command (
 import Numeric (showHex)
 import GHC.Generics (Generic)
 import Data.Aeson (FromJSON)
-import Parameter
-import Common
+import Types
+import Parameter()
 
 
-type CommandCode = Byte
-
-
-data Command = Command {
-    cc :: CommandCode
-   ,parameters :: [Parameter]
-} deriving (Generic)
-
 instance FromJSON Command
 
 
 instance Show Command where
 
-    show (Command c ps) = "CMD: " ++ " cc:" ++ showHex c " " ++ show ps
-
+    show (Command c ps) = "CMD: " ++ " cc:" ++ showHex c " " ++ show ps

Common.hs

@@ -1,12 +1,7 @@
 module Common where
 
 import Data.BitVector hiding (showHex)
-import Data.Word
-
-
-type Byte = Word8
-
-type Frequency = Double
+import Types
 
 
 safeBitVec :: (Integral a, Show a) => Int -> a -> BV

Controller.hs

@@ -4,29 +4,12 @@ module Controller where
 
 import Data.Aeson (FromJSON)
 import GHC.Generics (Generic)
+import Types
 
 
-data Controller = Controller {
-     meta :: ControllerMeta
-    ,sequenced :: [MessageMeta]
-    ,parallel :: [MessageMeta]
-} deriving (Show, Generic)
-
-instance FromJSON Controller
-
-
-data ControllerMeta = ControllerMeta {
-     ip :: String
-    ,port :: Integer
-} deriving (Show, Generic)
-
 instance FromJSON ControllerMeta
 
-
-data MessageMeta = MessageMeta {
-     file :: FilePath
-    ,frequency :: Double
-} deriving (Show, Generic)
+instance FromJSON Controller
 
 instance FromJSON MessageMeta
 

Data.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data where
+
+import qualified Data.ByteString.Lazy as B
+import Data.ByteString.Lazy.Builder
+import Data.Vector (toList)
+import Foreign.Marshal.Utils (fromBool)
+import Control.Applicative ((<$>), (<*>))
+import Data.Aeson
+import Data.Aeson.Types
+import Types
+
+
+packData :: Data -> [Byte]
+packData (S s n) = (b2w (string7 s)) ++ replicate (n - length s) 0
+packData (B b)   =  b2w . word8 . fromBool $ b
+packData (I8 i)  =  b2w . int8 $ i
+packData (W8 w)  =  b2w . word8 $ w
+packData (I16 i) =  b2w . int16LE $ i
+packData (W16 w) =  b2w . word16LE $ w
+packData (I32 i) =  b2w . int32LE $ i
+packData (W32 w) =  b2w . word32LE $ w
+packData (I64 i) =  b2w . int64LE $ i
+packData (W64 w) =  b2w . word64LE $ w
+packData (F f)   =  b2w . floatLE $ f
+packData (D d)   =  b2w . doubleLE $ d
+packData (Arr a) =  concatMap packData a
+packData _ = error "Invalid data type for packData."
+
+
+
+b2w :: Builder -> [Byte]
+b2w = B.unpack . toLazyByteString
+
+
+instance FromJSON Data where
+
+    parseJSON (Object o) = do
+        typ <- o .: "type"
+        case typ of
+            "string" -> S   <$> o .: "value" <*> o .: "length"
+            "bool"   -> B   <$> o .: "value"
+            "int8"   -> I8  <$> o .: "value"
+            "uint8"  -> W8  <$> o .: "value"
+            "int16"  -> I16 <$> o .: "value"
+            "uint16" -> W16 <$> o .: "value"
+            "int32"  -> I32 <$> o .: "value"
+            "uint32" -> W32 <$> o .: "value"
+            "int64"  -> I64 <$> o .: "value"
+            "uint64" -> W64 <$> o .: "value"
+            "float"  -> F   <$> o .: "value"
+            "double" -> D   <$> o .: "value"
+            "array"  -> do
+                elemTyp <- (o .: "element_type") :: Parser String
+                vals <- (o .: "values") :: Parser Array
+                elems <- mapM (parseJSON . makeElem elemTyp) (toList vals)
+                return $ Arr elems
+            t -> error $ "Invalid argument type: " ++ t
+        where
+            makeElem t v = object ["type" .= t, "value" .= v]
+
+    parseJSON _ = error "Invalid message definition."

Main.hs

@@ -1,14 +1,28 @@
+{-# LANGUAGE NamedFieldPuns, FlexibleContexts #-}
+
+
 --import System.Environment (getArgs)
 import Control.Monad
+import Control.Applicative ((<$>))
 import Control.Concurrent
+import System.FilePath.Posix (takeExtensions)
+import System.IO (hFlush, stdout)
+import Data.Aeson (FromJSON)
+import qualified Data.ByteString.Lazy as B
+import qualified Data.Map as M
+import Data.List (transpose)
+import Auto
 import Controller
 import Send
 import Parse
+import Types
+import CCSDS
+import Message
 
 
 main :: IO ()
 --main = mapM (parseFile >=> run) <$> getArgs
-main = (parseFile >=> run) "main.ctrl"
+main = (parseFile >=> runner) "main.ctrl"
 
 
 myForkIO :: IO () -> IO (MVar ())
@@ -22,10 +36,37 @@ myForkIOs :: [IO ()] -> IO ()
 myForkIOs actions = mapM myForkIO actions >>= mapM_ takeMVar
 
 
-run :: Controller -> IO ()
-run (Controller {meta=cm, sequenced=s, parallel=p}) = do
-    let actions = mapM_ go s : map go p
+runner :: Controller -> IO ()
+runner (Controller {meta=cm, sequenced=s, parallel=p}) =
     --myForkIOs actions
     sequence_ actions
     where
-        go mm = void $ send cm (frequency mm) (file mm)
+        actions = mapM_ (run cm) s : map (run cm) p
+
+
+run :: ControllerMeta -> MessageMeta -> IO ()
+run (ControllerMeta {ip, port}) (MessageMeta {file, frequency}) = do
+    packed <- getPacked
+    forM_ packed $ (\p -> do
+        sendUDP ip port p
+        print p
+        hFlush stdout
+        threadDelay . round $ 1000000 / frequency
+        )
+    where
+        getPacked =
+            case takeExtensions file of
+                ".tlm" -> pack <$> (parseFile file :: IO (MessageDef Telemetry))
+                ".cmd" -> pack <$> (parseFile file :: IO (MessageDef Command))
+
+
+pack :: (FromJSON a, CCSDS (Message a)) => MessageDef a -> [B.ByteString]
+pack (MessageDef {variables=vs, message=m}) = do
+    map (runAuto (packCCSDS m)) $ makeEnvs vs
+    where
+        varToPairs (Variable id_ ds) = [(id_, Parameter id_ d) | d <- ds]
+        makeEnvs vs =
+            let jaggedPairs = map varToPairs vs in
+            let smallestLen = minimum . map length $ jaggedPairs in
+            let flushPairs = map (take smallestLen) jaggedPairs in
+            map Config . map M.fromList . transpose $ flushPairs

Message.hs

@@ -15,12 +15,9 @@ import Command
 import Telemetry
 import Parameter
 import Variable
+import Types
 
 
-type MessageID = Byte
-
-
-data Message a = Message MessageID a deriving (Show)
 
 
 instance (FromJSON a) => FromJSON (Message a) where
@@ -29,11 +26,6 @@ instance (FromJSON a) => FromJSON (Message a) where
     parseJSON _ = error "Invalid message definition."
 
 
-data MessageDef a = MessageDef {
-    variables :: [Variable]
-   ,message :: Message a
-} deriving (Show, Generic)
-
 instance (FromJSON a) => FromJSON (MessageDef a)