Commit 1e2524 initial

10 files Merged and Committed by Richard Marko 2 years ago
initial

    
1 @@ -0,0 +1,1 @@
2 + .stack-work
 1 @@ -0,0 +1,30 @@
 2 + Copyright (C) 2017, Galois, Inc.
 3 + 
 4 + All rights reserved.
 5 + 
 6 + Redistribution and use in source and binary forms, with or without
 7 + modification, are permitted provided that the following conditions are met:
 8 + 
 9 +     * Redistributions of source code must retain the above copyright
10 +       notice, this list of conditions and the following disclaimer.
11 + 
12 +     * Redistributions in binary form must reproduce the above
13 +       copyright notice, this list of conditions and the following
14 +       disclaimer in the documentation and/or other materials provided
15 +       with the distribution.
16 + 
17 +     * Neither the name of Author name here nor the names of other
18 +       contributors may be used to endorse or promote products derived
19 +       from this software without specific prior written permission.
20 + 
21 + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
27 + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28 + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29 + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30 + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
31 + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 1 @@ -0,0 +1,12 @@
 2 + ivory-tower-hxstream
 3 + ====================
 4 + 
 5 + HX stream protocol
 6 + 
 7 + Provides simple encoding and tagging of frames. Useful for framing
 8 + protocol data.
 9 + 
10 + Contains native Haskell implementation, Ivory functions and Tower programs
11 + for encoding and decoding streams.
12 + 
13 + Extracted from smaccmpilot-stm32f4/smaccm-datalink repository by Galois, Inc.
1 @@ -0,0 +1,2 @@
2 + import Distribution.Simple
3 + main = defaultMain
 1 @@ -0,0 +1,32 @@
 2 + name:                ivory-tower-hxstream
 3 + version:             0.1.0.0
 4 + synopsis:            HX stream libraray
 5 + -- description:
 6 + license:             BSD3
 7 + author:              Galois, Inc.
 8 + maintainer:          srk@48.io
 9 + -- category:
10 + build-type:          Simple
11 + cabal-version:       >=1.10
12 + 
13 + library
14 +   hs-source-dirs:      src
15 +   exposed-modules:     HXStream.Native,
16 +                        HXStream.Ivory,
17 +                        HXStream.Ivory.Types,
18 +                        HXStream.Tower
19 + 
20 +   build-depends:       base >= 4.6,
21 +                        bytestring,
22 +                        dlist,
23 +                        monadLib,
24 +                        ivory,
25 +                        ivory-stdlib,
26 +                        ivory-serialize,
27 +                        ivory-hw,
28 +                        tower              >= 0.9,
29 +                        tower-config,
30 +                        tower-hal
31 + 
32 +   default-language:    Haskell2010
33 +   ghc-options:         -Wall
  1 @@ -0,0 +1,237 @@
  2 + {-# LANGUAGE DataKinds #-}
  3 + {-# LANGUAGE TypeOperators #-}
  4 + {-# LANGUAGE FlexibleInstances #-}
  5 + {-# LANGUAGE QuasiQuotes #-}
  6 + {-# LANGUAGE ScopedTypeVariables #-}
  7 + {-# LANGUAGE Rank2Types #-}
  8 + 
  9 + {-# OPTIONS_GHC -fno-warn-orphans #-}
 10 + 
 11 + -- Hx streaming library.
 12 + 
 13 + module HXStream.Ivory where
 14 + 
 15 + import Ivory.Language
 16 + import Ivory.Stdlib
 17 + import HXStream.Ivory.Types
 18 + 
 19 + --------------------------------------------------------------------------------
 20 + 
 21 + type Hx  = 'Struct "hxstream_state"
 22 + type Tag = Uint8
 23 + 
 24 + [ivory|
 25 + 
 26 + struct hxstream_state
 27 +   { offset  :: Stored Sint32
 28 +   ; fstate  :: Stored HXState
 29 +   ; ftag    :: Stored Uint8 -- Frame tag
 30 +   ; tagSeen :: Stored IBool -- Has a tag been processed in the current frame?
 31 +   }
 32 + 
 33 + |]
 34 + 
 35 + --------------------------------------------------------------------------------
 36 + 
 37 + emptyStreamState :: Ref s Hx -> Ivory eff ()
 38 + emptyStreamState state = do
 39 +   store (state ~> offset)  0
 40 +   store (state ~> fstate)  hxstate_progress
 41 +   store (state ~> tagSeen) false
 42 +   -- Don't care about the frame tag---shouldn't be read unless there's a new
 43 +   -- frame.
 44 + 
 45 + -- Should match the initialization in the empty state.
 46 + initStreamState :: Init ('Struct "hxstream_state")
 47 + initStreamState = istruct [ fstate  .=  ival hxstate_progress
 48 +                           , offset  .=  ival 0
 49 +                           , tagSeen .= ival false
 50 +                           ]
 51 + 
 52 + --------------------------------------------------------------------------------
 53 + -- State-setting helpers
 54 + 
 55 + setState :: Ref s Hx -> HXState -> Ivory eff ()
 56 + setState state = store (state ~> fstate)
 57 + 
 58 + setTag :: Ref s Hx -> Tag -> Ivory eff ()
 59 + setTag state t = do
 60 +   store (state ~> ftag) t
 61 +   store (state ~> tagSeen) true
 62 + 
 63 + -- Increment the offset by one.
 64 + tickOffset :: Ref s Hx -> Ivory eff ()
 65 + tickOffset state = do
 66 +   off <- state ~>* offset
 67 +   store (state ~> offset) (off+1)
 68 + 
 69 + --------------------------------------------------------------------------------
 70 + -- Hxstream bytes
 71 + 
 72 + fbo :: Uint8
 73 + fbo  = 0x7e
 74 + 
 75 + ceo :: Uint8
 76 + ceo  = 0x7c
 77 + 
 78 + --------------------------------------------------------------------------------
 79 + 
 80 + escape :: Uint8 -> Uint8
 81 + escape = (.^) 0x20 -- XOR with 0x20
 82 + 
 83 + --------------------------------------------------------------------------------
 84 + 
 85 + -- | Decode a byte, given an hxstream state.  Returns a byte.  When the function
 86 + -- returns, if the hxstate makes the following transitions, we have the
 87 + -- following bytes returned:
 88 + --
 89 + -- hxstate_tag      --> hxstate_progress : tag byte
 90 + -- hxstate_progress --> hxstate_progress : frame byte
 91 + -- hxstate_esc      --> hxstate_progress : escaped frame byte
 92 + --
 93 + -- If we have
 94 + --
 95 + -- hxstate_progress --> hxstate_tag
 96 + --
 97 + -- A frame just ended.
 98 + decodeSM :: Def ('[ Ref s Hx, Uint8 ] ':-> Uint8)
 99 + decodeSM = proc "decodeSM" $ \state b -> body $ do
100 +   st <- state ~>* fstate
101 +   byteRef <- local (ival 0)
102 +   cond_
103 +     [   -- If you see fbo, we're starting a new frame.
104 +         b ==? fbo
105 +     ==> emptyStreamState state >> setState state hxstate_tag
106 +         -- Get the tag in the tag state and get ready to process the rest.
107 +     ,   st ==? hxstate_tag
108 +     ==> setTag state b >> setState state hxstate_progress
109 +         -- Progress
110 +     ,   st ==? hxstate_progress
111 +     ==> progress state b byteRef
112 +         -- Handle escaped bytes.
113 +     ,   st ==? hxstate_esc
114 +     ==> do setState state hxstate_progress
115 +            tickOffset state
116 +            store byteRef (escape b)
117 +         -- The impossible happened.
118 +     ,   true
119 +     ==> return ()
120 +     ]
121 +   ret =<< deref byteRef
122 +   where
123 +   progress state b byteRef =
124 +     cond_ [ b ==? ceo ==> setState state hxstate_esc
125 +           , true      ==> tickOffset state >> store byteRef b
126 +           ]
127 + 
128 + --------------------------------------------------------------------------------
129 + 
130 + newtype FrameHandler =
131 +   FrameHandler { unFrameHandler :: forall s. ScopedFrameHandler s }
132 + 
133 + mkFrameHandler :: (forall s. ScopedFrameHandler s) -> FrameHandler
134 + mkFrameHandler = FrameHandler
135 + 
136 + data ScopedFrameHandler s =
137 +   ScopedFrameHandler
138 +     { -- Tag to match.  Only matching frames with a matching tag will be
139 +       -- handled.
140 +       fhTag   :: Tag
141 +       -- What to do before parsing the frame, after matching the tag.
142 +     , fhBegin :: Ivory (AllocEffects s) ()
143 +       -- What to do with a byte of frame data.  Can use the index.
144 +     , fhData  :: Uint8 -> Sint32 -> Ivory (AllocEffects s) ()
145 +       -- What to do at the end of the frame.
146 +     , fhEnd   :: Ivory (AllocEffects s) ()
147 +     }
148 + 
149 + -- | Decode a byte given a list of frame handlers.
150 + decodes :: forall s0 s1 . [FrameHandler]
151 +         -> Ref s1 Hx
152 +         -> Uint8
153 +         -> Ivory (AllocEffects s0) ()
154 + decodes fhs state b = do
155 +   -- State before decoding byte.
156 +   st0  <- state ~>* fstate
157 +   off  <- state ~>* offset
158 +   tagB <- state ~>* tagSeen
159 + 
160 +   byte <- call decodeSM state b
161 + 
162 +   -- State after decoding byte.
163 +   st1  <- state ~>* fstate
164 +   tag  <- state ~>* ftag
165 + 
166 +   -- Run each framehandler for which the tag matches.
167 +   let go k (FrameHandler fh) = when (tag ==? fhTag fh) (k fh)
168 +   let fhLookup :: (ScopedFrameHandler s0 -> Ivory (AllocEffects s0) ())
169 +                -> Ivory (AllocEffects s0) ()
170 +       fhLookup k = mapM_ (go k) fhs
171 + 
172 +   cond_
173 +     [   -- Frame ended and we processed a full frame, including the tag.
174 +         (st0 ==? hxstate_progress) .&& (st1 ==? hxstate_tag) .&& tagB
175 +     ==> fhLookup fhEnd
176 +         -- Getting tag: run beginning action for frame.
177 +     ,   (st0 ==? hxstate_tag)
178 +     ==> fhLookup fhBegin
179 +         -- Got a frame byte: process it.
180 +     ,   (st0 ==? hxstate_progress) .|| (st0 ==? hxstate_esc)
181 +     ==> fhLookup (\fh -> fhData fh byte off)
182 +         -- Idle otherwise.
183 +     ,   true
184 +     ==> return ()
185 +    ]
186 + 
187 + -- | Decode a frame given a frame state and byte and a set of framehandler
188 + -- functions.
189 + decode :: FrameHandler
190 +        -> Ref s1 Hx
191 +        -> Uint8
192 +        -> Ivory (AllocEffects s0) ()
193 + decode fh = decodes [fh]
194 + 
195 + --------------------------------------------------------------------------------
196 + 
197 + -- | Takes a tag, frame array, and a 'put' function and encodes according to the
198 + -- hxstream protocol.
199 + encode ::   ANat n
200 +          => Tag
201 +          -> ConstRef s ('Array n ('Stored Uint8))
202 +          -> (Uint8 -> Ivory ('Effects r 'NoBreak a) ())
203 +          -> Ivory ('Effects r b a) ()
204 + encode tag arr put = noBreak $ do
205 +   put fbo
206 +   put tag
207 +   putencoded
208 +   put fbo
209 +   where
210 +   putencoded = arrayMap $ \ix -> noBreak $ do
211 +     v  <- deref (arr ! ix)
212 +     ifte_ ((v ==? fbo) .|| (v ==? ceo))
213 +           (put ceo >> put (escape v))
214 +           (put v)
215 + 
216 + encodeString :: (ANat n, IvoryString str)
217 +              => Tag
218 +              -> ConstRef s1 ('Array n ('Stored Uint8))
219 +              -> Ref s2 str
220 +              -> Ivory ('Effects r b a) ()
221 + encodeString tag arr str = do
222 +   total <- deref $ str ~> stringLengthL
223 +   let strlen = arrayLen (str ~> stringDataL)
224 +   assert $ arrayLen arr * 2 + 3 <=? strlen .|| total * 2 + 3 <=? strlen
225 +   encode tag arr $ \ ch -> do
226 +     queued <- deref $ str ~> stringLengthL
227 +     assert $ queued <? arrayLen (str ~> stringDataL)
228 +     store (str ~> stringDataL ! toIx queued) ch
229 +     store (str ~> stringLengthL) (queued + 1)
230 + 
231 + --------------------------------------------------------------------------------
232 + 
233 + hxstreamModule :: Module
234 + hxstreamModule = package "hxstream_state_module" $ do
235 +   defStruct (Proxy :: Proxy "hxstream_state")
236 +   incl decodeSM
237 + 
238 + --------------------------------------------------------------------------------
 1 @@ -0,0 +1,23 @@
 2 + {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 3 + {-# LANGUAGE FlexibleInstances #-}
 4 + {-# LANGUAGE DataKinds #-}
 5 + 
 6 + module HXStream.Ivory.Types
 7 +   ( HXState
 8 +   , hxstate_tag
 9 +   , hxstate_progress
10 +   , hxstate_esc
11 +   ) where
12 + 
13 + import Ivory.Language
14 + 
15 + -- Idea: this pattern is useful, could we make an ivoryenum quasiquoter
16 + -- for defining these automatically?
17 + 
18 + newtype HXState = HXState Uint8
19 +   deriving (IvoryType, IvoryVar, IvoryExpr, IvoryEq, IvoryStore, IvoryInit)
20 + 
21 + hxstate_tag, hxstate_progress, hxstate_esc  :: HXState
22 + hxstate_tag        = HXState 1
23 + hxstate_progress   = HXState 2
24 + hxstate_esc        = HXState 3
  1 @@ -0,0 +1,149 @@
  2 + {-# OPTIONS_GHC -fno-warn-orphans #-}
  3 + {-# LANGUAGE CPP #-}
  4 + {-# LANGUAGE FlexibleInstances  #-}
  5 + {-# LANGUAGE StandaloneDeriving #-}
  6 + 
  7 + #if __GLASGOW_HASKELL__ < 709
  8 + {-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-}
  9 + {-# LANGUAGE OverlappingInstances #-}
 10 + #endif
 11 + 
 12 + -- | Haskell implementation of the Hxstream protocol.
 13 + 
 14 + module HXStream.Native
 15 +   ( FrameState(..)
 16 +   , StreamState(..)
 17 +   , fbo
 18 +   , ceo
 19 +   , emptyStreamState
 20 +   , extractFrame
 21 +   , decodeSM
 22 +   , decodeByte
 23 +   , decode
 24 +   , encode
 25 +   , Tag
 26 +   ) where
 27 + 
 28 + import           Data.Bits
 29 + import qualified Data.ByteString as B
 30 + import           Data.Word
 31 + import qualified Data.DList as D
 32 + 
 33 + --------------------------------------------------------------------------------
 34 + 
 35 + type Tag = Word8
 36 + 
 37 + instance {-# OVERLAPPING #-} Show (D.DList Word8) where
 38 +   show = show . D.toList
 39 + 
 40 + data FrameState = FrameTag
 41 +                 | FrameProgress
 42 +                 | FrameEscape
 43 +                 deriving (Eq, Show)
 44 + 
 45 + data StreamState =
 46 +   StreamState
 47 +     { frame   :: D.DList Word8  -- Current frame
 48 +     , ftag    :: Maybe Word8
 49 +     , fstate  :: FrameState
 50 +     } deriving Show
 51 + 
 52 + emptyStreamState :: StreamState
 53 + emptyStreamState = StreamState D.empty Nothing FrameProgress
 54 + 
 55 + -- | Get a `ByteString` frame from a frame state.
 56 + extractFrame :: StreamState -> B.ByteString
 57 + extractFrame = B.pack . D.toList . frame
 58 + 
 59 + -- Append a byte to the frame, escaping if needed.  Assumes we're in the
 60 + -- progress state.
 61 + appendFrame :: Word8 -> StreamState -> StreamState
 62 + appendFrame b s = s { frame = frame s .++ b }
 63 + 
 64 + -- | Frame Boundary Octet
 65 + fbo :: Word8
 66 + fbo  = 0x7e
 67 + -- | Control Escape Octet
 68 + ceo :: Word8
 69 + ceo  = 0x7c
 70 + 
 71 + -- | Escape transformation
 72 + escape :: Word8 -> Word8
 73 + escape b = b `xor` 0x20
 74 + 
 75 + -- | When fstate state == FrameTag, the input state contains a completed frame.
 76 + -- The new state is reset.
 77 + decodeSM :: Word8 -> StreamState -> StreamState
 78 + decodeSM b state
 79 +   -- If you see fbo, we're starting a new frame.
 80 +   | b == fbo
 81 +   = emptyStreamState { fstate = FrameTag }
 82 +   -- Process the tag byte.
 83 +   | fstate state == FrameTag
 84 +   = state { ftag = Just b, fstate = FrameProgress }
 85 +   -- Progress
 86 +   | fstate state == FrameProgress
 87 +   = progress
 88 +   -- Handle escpaed bytes.
 89 +   | fstate state == FrameEscape
 90 +   = appendFrame (escape b) state { fstate = FrameProgress }
 91 +   -- The impossible happened.  Reset.
 92 +   | otherwise
 93 +   = emptyStreamState
 94 +   where
 95 +   progress
 96 +     -- If you see ceo, set escape.
 97 +     | b == ceo
 98 +     = state { fstate = FrameEscape }
 99 +     -- Otherwise, append bytes to our current frame.
100 +     | otherwise
101 +     = appendFrame b state
102 + 
103 + -- | Decode an hxstream.  Returns a list of decoded frames and their tags.
104 + decode :: B.ByteString
105 +        -> StreamState
106 +        -> ([(Tag, B.ByteString)], StreamState)
107 + decode bs state = (D.toList dframes, newSt)
108 +   where
109 +   (dframes, newSt) = B.foldl' aux (D.empty, state) bs
110 +   aux (fs,st) b =
111 +     case fstate st' of
112 +       FrameTag -> case ftag st of
113 +                     -- No tag, throw the frame away.
114 +                     Nothing -> (fs, st')
115 +                     Just t  -> (fs .++ (t, extractFrame st), st')
116 +       _        -> (fs, st')
117 +     where
118 +     st' = decodeSM b st
119 + 
120 + -- | Decode an hxstream.  Returns a list of decoded frames and their tags.
121 + decodeByte :: Word8
122 +            -> StreamState
123 +            -> (Maybe (Tag, B.ByteString), StreamState)
124 + decodeByte b state = (r, st')
125 +   where
126 +   st' = decodeSM b state
127 +   r = case fstate st' of
128 +       FrameTag ->
129 +         case ftag state of
130 +            Just t  -> Just (t, extractFrame state)
131 +            Nothing -> Nothing
132 +       _ -> Nothing
133 + 
134 + encode :: Tag -> B.ByteString -> B.ByteString
135 + encode tag ws' = B.pack $ D.toList $ fbo .: tag .: go ws
136 +   where
137 +   ws = B.unpack ws'
138 +   go (x:xs) | x == fbo  = ceo .: (escape x .: go xs)
139 +             | x == ceo  = ceo .: (escape x .: go xs)
140 +             | otherwise = x .: go xs
141 +   go [] = D.singleton fbo
142 + 
143 + -- Helpers
144 + 
145 + (.:) :: a -> D.DList a -> D.DList a
146 + (.:) = D.cons
147 + infixr .:
148 + 
149 + (.++) :: D.DList a -> a -> D.DList a
150 + (.++) = D.snoc
  1 @@ -0,0 +1,151 @@
  2 + {-# LANGUAGE DataKinds #-}
  3 + {-# LANGUAGE ExistentialQuantification #-}
  4 + {-# LANGUAGE FlexibleInstances #-}
  5 + {-# LANGUAGE QuasiQuotes #-}
  6 + {-# LANGUAGE RecordWildCards #-}
  7 + {-# LANGUAGE ScopedTypeVariables #-}
  8 + {-# LANGUAGE TypeFamilies #-}
  9 + {-# OPTIONS_GHC -fno-warn-orphans #-}
 10 + 
 11 + module HXStream.Tower
 12 +   ( hxstreamEncodeTower
 13 +   , hxstreamEncodeTower'
 14 +   , HXStreamHandler()
 15 +   , hxstreamHandler
 16 +   , hxstreamHandler'
 17 +   , hxstreamDecodeTower
 18 +   ) where
 19 + 
 20 + import Control.Monad (forM)
 21 + import Ivory.Language
 22 + import Ivory.Serialize
 23 + import Ivory.Stdlib
 24 + import Ivory.Tower
 25 + import Ivory.Tower.HAL.Bus.Interface
 26 + import Ivory.Tower.HAL.RingBuffer
 27 + 
 28 + import qualified HXStream.Ivory as H
 29 + 
 30 + hxstreamEncodeTower :: forall str msg len pop_period buf_size e
 31 +                      . (IvoryString str, Packable msg, IvoryArea msg, IvoryZero msg, ANat len, Time pop_period, ANat buf_size)
 32 +                     => String
 33 +                     -> ChanOutput msg
 34 +                     -> Proxy len
 35 +                     -> H.Tag
 36 +                     -> BackpressureTransmit str ('Stored IBool)
 37 +                     -> pop_period
 38 +                     -> Proxy buf_size
 39 +                     -> Tower e ()
 40 + hxstreamEncodeTower n = hxstreamEncodeTower' n packRep
 41 + 
 42 + 
 43 + hxstreamEncodeTower' :: forall str msg len pop_period buf_size e
 44 +                       . (IvoryString str, IvoryArea msg, IvoryZero msg, ANat len, Time pop_period, ANat buf_size)
 45 +                      => String
 46 +                      -> PackRep msg
 47 +                      -> ChanOutput msg
 48 +                      -> Proxy len
 49 +                      -> H.Tag
 50 +                      -> BackpressureTransmit str ('Stored IBool)
 51 +                      -> pop_period
 52 +                      -> Proxy buf_size
 53 +                      -> Tower e ()
 54 + hxstreamEncodeTower' n rep ct_chan buflen tag (BackpressureTransmit serial_chan complete) pop_period _buf_size = do
 55 +   let deps = [H.hxstreamModule, serializeModule]
 56 +   mapM_ towerModule deps
 57 +   mapM_ towerArtifact serializeArtifacts
 58 + 
 59 +   p <- period pop_period
 60 +   ct_chan_buf <- channel
 61 + 
 62 +   monitor (n ++ "_datalink_encode") $ do
 63 +     monitorModuleDef $ mapM_ depend deps
 64 +     (rb :: RingBuffer buf_size msg) <- monitorRingBuffer "datalink_encode"
 65 + 
 66 +     pending <- state "pending"
 67 + 
 68 +     handler ct_chan "encoder_ct_push" $ do
 69 +       callback $ \msg -> do
 70 +         _ <- ringbuffer_push rb msg
 71 +         -- dropped message!
 72 +         return ()
 73 + 
 74 +     handler p "periodic_encoder_ct_pop" $ do
 75 +       e <- emitter (fst ct_chan_buf) 1
 76 +       callback $ const $ do
 77 +         already_pending <- deref pending
 78 +         unless already_pending $ do
 79 +           msg <- local izero
 80 +           got <- ringbuffer_pop rb msg
 81 +           ifte_ got (emit e (constRef msg)) (return ())
 82 + 
 83 +     handler (snd ct_chan_buf) "encoder_ct_output" $ do
 84 +       e <- emitter serial_chan 1
 85 +       callback $ \ msg -> do
 86 +         ct <- local (izerolen buflen)
 87 +         packInto' rep ct 0 msg
 88 +         buf <- local izero
 89 +         H.encodeString tag (constRef ct) buf
 90 +         emit e $ constRef buf
 91 +         store pending true
 92 + 
 93 +     handler complete "complete" $ callback $ const $ store pending false
 94 + 
 95 + data HXStreamHandler = forall msg. (IvoryArea msg, IvoryZero msg) => HXStreamHandler
 96 +   { handlerTag :: H.Tag
 97 +   , handlerPackRep :: PackRep msg
 98 +   , handlerChan :: ChanInput msg
 99 +   }
100 + 
101 + hxstreamHandler :: (Packable msg, IvoryArea msg, IvoryZero msg) => H.Tag -> ChanInput msg -> HXStreamHandler
102 + hxstreamHandler t c = hxstreamHandler' t packRep c
103 + 
104 + hxstreamHandler' :: (IvoryArea msg, IvoryZero msg) => H.Tag -> PackRep msg -> ChanInput msg -> HXStreamHandler
105 + hxstreamHandler' = HXStreamHandler
106 + 
107 + hxstreamDecodeTower :: ANat len
108 +                     => String
109 +                     -> ChanOutput ('Stored Uint8)
110 +                     -> Proxy len
111 +                     -> [HXStreamHandler]
112 +                     -> Tower e ()
113 + hxstreamDecodeTower n serial_chan buflen handlers = do
114 +   let deps = [H.hxstreamModule, serializeModule]
115 +   mapM_ towerDepends deps
116 +   mapM_ towerModule  deps
117 +   mapM_ towerArtifact serializeArtifacts
118 + 
119 +   monitor (n ++ "_datalink_decode") $ do
120 +     monitorModuleDef $ depend H.hxstreamModule
121 +     hx <- stateInit "hx_decoder" H.initStreamState
122 +     buf <- stateInit "buf" (izerolen buflen)
123 +     overrun <- state "overrun"
124 + 
125 +     handler serial_chan "decoder_serial_in" $ do
126 +       emitters <- forM handlers $ \ HXStreamHandler { .. } -> do
127 +         let needed = packSize handlerPackRep * 2 + 3
128 +         e <- if needed <= arrayLen buf
129 +           then emitter handlerChan 1
130 +           else fail $
131 +             "handler needs buffer length at least " ++ show needed ++
132 +             " but was only given " ++ show (arrayLen buf :: Int) ++ " bytes"
133 + 
134 +         return $ H.mkFrameHandler H.ScopedFrameHandler
135 +           { H.fhTag = handlerTag
136 +           , H.fhBegin = do
137 +               store overrun false
138 +               arrayMap $ \ix -> store (buf ! ix) 0
139 +           , H.fhData = \v offs ->
140 +               -- by transitivity of (<), offs < arrayLen buf
141 +               ifte_ (offs <? fromInteger needed)
142 +                     (store (buf ! toIx offs) v)
143 +                     (store overrun true)
144 +           , H.fhEnd = do
145 +               o <- deref overrun
146 +               unless o $ do
147 +                 decoded <- local izero
148 +                 unpackFrom' handlerPackRep (constRef buf) 0 decoded
149 +                 emit e (constRef decoded)
150 +           }
151 + 
152 +       callbackV $ H.decodes emitters hx
 1 @@ -0,0 +1,57 @@
 2 + # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html
 3 + 
 4 + # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
 5 + resolver: lts-8.9
 6 + 
 7 + # Local packages, usually specified by relative directory name
 8 + packages:
 9 + - '.'
10 + - location: ../ivory-tower-stm32/
11 +   extra-dep: true
12 +   subdirs:
13 +     - ivory-bsp-stm32
14 +     - ivory-bsp-tests
15 +     - ivory-freertos-bindings
16 +     - tower-freertos-stm32
17 +     - tower-echronos-stm32
18 + - location: ../ivory/
19 +   extra-dep: true
20 +   subdirs:
21 +     - ivory
22 +     - ivory-artifact
23 +     - ivory-backend-c
24 +     - ivory-hw
25 +     - ivory-opts
26 +     - ivory-serialize
27 +     - ivory-stdlib
28 + - location: ../tower/
29 +   extra-dep: true
30 +   subdirs:
31 +     - tower
32 +     - tower-config
33 +     - tower-hal
34 +     - tower-aadl
35 + 
36 + # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
37 + extra-deps: []
38 + 
39 + # Override default flag values for local packages and extra-deps
40 + flags: {}
41 + 
42 + # Extra package databases containing global packages
43 + extra-package-dbs: []
44 + 
45 + # Require a specific version of stack, using version ranges
46 + # require-stack-version: -any # Default
47 + # require-stack-version: >= 1.0.0
48 + 
49 + # Override the architecture used by stack, especially useful on Windows
50 + # arch: i386
51 + # arch: x86_64
52 + 
53 + # Extra directories used by stack for building
54 + # extra-include-dirs: [/path/to/dir]
55 + # extra-lib-dirs: [/path/to/dir]
56 + 
57 + # Allow a newer minor version of GHC than the snapshot specifies
58 + # compiler-check: newer-minor