Merge pull request #4 from distrap/srk/chores

Untick `:->`

cabal.project

@@ -8,7 +8,7 @@ packages:
 source-repository-package
   type: git
   location: https://github.com/distrap/ivory
-  tag: 802a976df29a5cac18b689b99f83f39d2f161319
+  tag: 69bae09d064042e2135df2894b613ed5eadd38fa
   subdir:
     ivory
     ivory-artifact

tower-aadl/src/Tower/AADL.hs

@@ -26,9 +26,11 @@ import           Data.Char
 import           Control.Monad hiding (forever)
 
 import           System.FilePath (addExtension, takeFileName, (<.>))
+import           System.IO (hPutStrLn, stderr)
 import           System.Exit (exitFailure)
-
+import           MonadLib (runWriterT)
 import           Text.PrettyPrint.Leijen hiding ((</>))
+import qualified Text.PrettyPrint
 
 import qualified Ivory.Compile.C.CmdlineFrontend as O
 import qualified Ivory.Compile.C.Types as O
@@ -108,7 +110,12 @@ compileTowerAADLForPlatform fromEnv mkEnv twr' = do
 
   unless (validCIdent appname) $ error $ "appname must be valid c identifier; '"
                                         ++ appname ++ "' is not"
-  cmodules <- O.compileUnits mods copts
+  (cmodules, errors) <- runWriterT $ O.compileUnits mods copts
+  hPutStrLn stderr
+    . Text.PrettyPrint.render
+    $ Text.PrettyPrint.vcat
+        errors
+
   let (appMods, libMods) =
         partition (\m -> O.unitName m `elem` pkgs) cmodules
   O.outputCompiler appMods (as osspecific) (osSpecificOptsApps osspecific cfg copts)

tower-aadl/test-echronos/Simple.hs

@@ -49,13 +49,13 @@ simpleTower = do
         call_ debug_println ""
 
 --------------------------------------------------------------------------------
-debug_println :: Def('[IString] ':-> ())
+debug_println :: Def('[IString] :-> ())
 debug_println = importProc "debug_println" "debug.h"
 
-debug_printhex8 :: Def('[Uint8] ':-> ())
+debug_printhex8 :: Def('[Uint8] :-> ())
 debug_printhex8 = importProc "debug_printhex8" "debug.h"
 
-debug_print :: Def('[IString] ':-> ())
+debug_print :: Def('[IString] :-> ())
 debug_print = importProc "debug_print" "debug.h"
 
 [ivory|

tower-aadl/tower-aadl.cabal

@@ -29,6 +29,8 @@ library
                , containers
                , directory
                , filepath
+               , monadLib >= 3.7
+               , pretty >= 1.1
                , wl-pprint
                , ivory >= 0.1.0.2
                , ivory-artifact

tower-hal/src/Ivory/Tower/HAL/Bus/CAN/Sched.hs

@@ -34,7 +34,7 @@ struct can_transmit_result
 shiftUp :: Def ('[ Ref s0 ('Stored Uint8)
                  , Ref s1 ('Stored Uint32), Ref s2 ('Stored Uint8)
                  , Ref s3 ('Stored Uint32), Ref s4 ('Stored Uint8)
-                 ] ':-> IBool)
+                 ] :-> IBool)
 shiftUp = proc "shift_task_up" $ \ insert_position new_prio new_task current_prio current_task -> body $ do
   new <- deref new_prio
   when (new ==? maxBound) $ ret true
@@ -55,7 +55,7 @@ shiftUp = proc "shift_task_up" $ \ insert_position new_prio new_task current_pri
 shiftDown :: Def ('[ Ref s0 ('Stored Uint8)
                    , Ref s1 ('Stored Uint32), Ref s2 ('Stored Uint8)
                    , ConstRef s3 ('Stored Uint32), ConstRef s4 ('Stored Uint8)
-                   ] ':-> IBool)
+                   ] :-> IBool)
 shiftDown = proc "shift_task_down" $ \ target_ref current_prio current_task next_prio next_task -> body $ do
   target <- deref target_ref
   when (target ==? maxBound) $ ret true
@@ -255,7 +255,7 @@ canScheduler mailboxes tasks = do
                             , Ref s1 ('Stored Uint8)
                             , Ref s2 ('Struct "can_message")
                             , ConstRef s3 ('Struct "can_message")
-                            ] ':-> IBool)
+                            ] :-> IBool)
         insertTask = proc "insert_task" $ \ task resched_task resched_mbox last_request req -> body $ do
           comment "Task must not have an outstanding request already."
           last_id <- deref $ last_request ~> can_message_id

tower-hal/src/Ivory/Tower/HAL/RingBuffer.hs

@@ -84,7 +84,7 @@ ringBuffer s = RingBuffer
     r <- deref remove
     return (i ==? r)
 
-  push_proc :: Def('[ConstRef s a]':->IBool)
+  push_proc :: Def('[ConstRef s a]:->IBool)
   push_proc = proc (named "push") $ \v -> body $ do
     f <- full
     ifte_ f (ret false) $ do
@@ -93,7 +93,7 @@ ringBuffer s = RingBuffer
       incr insert >>= store insert
       ret true
 
-  pop_proc :: Def('[Ref s a]':->IBool)
+  pop_proc :: Def('[Ref s a]:->IBool)
   pop_proc = proc (named "pop") $ \v -> body $ do
     e <- empty
     ifte_ e (ret false) $ do

tower-mini/src/Tower/Mini.hs

@@ -42,7 +42,9 @@ import Data.List                 (partition)
 import MonadLib                  (forM_, runWriterT, when)
 import System.FilePath           ((</>))
 import System.Exit               (exitFailure)
+import System.IO (hPutStrLn, stderr)
 import Text.PrettyPrint.Mainland ((<+>), putDoc, text)
+import Text.PrettyPrint (render, vcat)
 
 import qualified Data.Map as Map
 
@@ -126,7 +128,7 @@ instance TowerBackend MiniBackend where
       ( Emitter $ \ref ->
           forM_ targetHandlers $ \(MiniHandler _ cbs _) ->
             forM_ cbs $ \cb ->
-              call_ (importProc (callbackName cb) "" :: Def('[ConstRef s b] ':-> ())) ref
+              call_ (importProc (callbackName cb) "" :: Def('[ConstRef s b] :-> ())) ref
       , MiniEmitter (\tow -> mkDepends tow)
       )
       where
@@ -241,7 +243,8 @@ compileTowerMini _fromEnv mkEnv comps = do
                             , outHdrDir = Just (f </> name </> "include")
                             , outArtDir = Just (f </> name)
                             }
-    cmodules <- compileUnits mods copts'
+    (cmodules, errors) <- runWriterT $ compileUnits mods copts'
+    hPutStrLn stderr $ render $ vcat errors
 
     let (appMods, libMods) =
           partition (\m -> unitName m `elem` packages) cmodules
@@ -281,21 +284,21 @@ buildComponent env (Component nm comp) = do
           dependByName monName
         forM_ (outputPeriodCallbacks code) $ \(_, monName) ->
           dependByName monName
-        let entryProc :: Def('[ConstRef s ('Stored Sint64)] ':-> ())
+        let entryProc :: Def('[ConstRef s ('Stored Sint64)] :-> ())
             entryProc = voidProc "component_entry" $ \i -> body $ do
               -- in the periodic loop, first call each of the
               -- functions generated for the input and output ports of
               -- the component
               forM_ runFns call_
               -- pass along the value coming from the glue code to periodic callbacks
               forM_ (outputPeriodCallbacks code) $ \(cbName, _) -> do
-                call_ (importProc cbName "" :: Def('[ConstRef s ('Stored Sint64)] ':-> ())) i
+                call_ (importProc cbName "" :: Def('[ConstRef s ('Stored Sint64)] :-> ())) i
               retVoid
-            initProc :: Def('[ConstRef s ('Stored Sint64)] ':-> ())
+            initProc :: Def('[ConstRef s ('Stored Sint64)] :-> ())
             initProc = voidProc "component_init" $ \i -> body $ do
               -- pass along the value coming from the glue code to init callbacks
               forM_ (outputInitCallbacks code) $ \(cbName, _) ->
-                call_ (importProc cbName "" :: Def('[ConstRef s ('Stored Sint64)] ':-> ())) i
+                call_ (importProc cbName "" :: Def('[ConstRef s ('Stored Sint64)] :-> ())) i
         private modDefs
         incl entryProc
         incl initProc

tower-mini/src/Tower/Mini/Component.hs

@@ -16,7 +16,7 @@ import Ivory.Language
 import Ivory.Tower
 
 newtype ComponentM e a = ComponentM {
-    unComponentM :: WriterT (ModuleDef, [Def('[] ':-> ())]) (Tower e) a
+    unComponentM :: WriterT (ModuleDef, [Def('[] :-> ())]) (Tower e) a
   } deriving (Functor, Monad, Applicative, MonadFix)
 
 instance BaseUtils ComponentM e where
@@ -125,9 +125,9 @@ inputPort' :: forall e a .
            -> ComponentM e ()
 inputPort' chan_in sym hdr = do
   let n = "input_" ++ sym
-  let ext_get_data :: Def('[Ref s a] ':-> IBool)
+  let ext_get_data :: Def('[Ref s a] :-> IBool)
       ext_get_data = importProc sym hdr
-      gen_mon_callback :: Def('[ConstRef s a] ':-> ())
+      gen_mon_callback :: Def('[ConstRef s a] :-> ())
       gen_mon_callback = importProc ("callback_" ++ n ++ "_handler") ""
   putComponentCode $ do
     incl $ ext_get_data
@@ -170,7 +170,7 @@ outputPort' :: forall e a .
             -> ComponentM e ()
 outputPort' chan_out sym hdr = do
   let n = "output_" ++ sym
-  let ext_put_data :: Def('[ConstRef s a] ':-> ())
+  let ext_put_data :: Def('[ConstRef s a] :-> ())
       ext_put_data = importProc sym hdr
   putComponentCode $ do
     incl $ ext_put_data

tower-mini/test/Integrated.hs

@@ -66,19 +66,19 @@ integratedTower = do
         call_ printf_bool "quux: %u\n" b'
         emitV e b'
 
-intermon1_get_data :: Def('[Ref s ('Stored Uint8)] ':-> IBool)
+intermon1_get_data :: Def('[Ref s ('Stored Uint8)] :-> IBool)
 intermon1_get_data = importProc "intermon1_get_data" "intermon1.h"
 
-intermon1_put_data :: Def('[ConstRef s ('Stored Uint8)] ':-> ())
+intermon1_put_data :: Def('[ConstRef s ('Stored Uint8)] :-> ())
 intermon1_put_data = importProc "intermon1_put_data" "intermon1.h"
 
-intermon2_get_data :: Def('[Ref s ('Stored IBool)] ':-> IBool)
+intermon2_get_data :: Def('[Ref s ('Stored IBool)] :-> IBool)
 intermon2_get_data = importProc "intermon2_get_data" "intermon2.h"
 
-intermon2_put_data :: Def('[ConstRef s ('Stored IBool)] ':-> ())
+intermon2_put_data :: Def('[ConstRef s ('Stored IBool)] :-> ())
 intermon2_put_data = importProc "intermon2_put_data" "intermon2.h"
 
-intermon1_callback :: Def('[ConstRef s ('Stored Uint8)] ':-> ())
+intermon1_callback :: Def('[ConstRef s ('Stored Uint8)] :-> ())
 intermon1_callback = importProc "callback_get_data" "intermon1_monitor.h"
 
 fooModule :: Module
@@ -88,7 +88,7 @@ fooModule = package "foo" $ do
   dependByName "intermon1_monitor"
   incl run
 
-run :: Def ('[] ':-> ())
+run :: Def ('[] :-> ())
 run = voidProc "run" $ body $ do
   intermon1_data <- local izero
   intermon1_has_data <- call intermon1_get_data intermon1_data
@@ -105,7 +105,7 @@ driverModule = package "driver" $ do
   incl printf_byte
   incl printf_bool
   depend fooModule
-  let ivoryMain :: Def('[] ':-> Sint32)
+  let ivoryMain :: Def('[] :-> Sint32)
       ivoryMain = proc "main" $ body $ do
         upTo (0 :: Ix 11) 10 $ \ix -> do
           byteRef <- local (ival (castDefault (fromIx ix)))
@@ -128,15 +128,15 @@ driverModule' = package "driver" $ do
   incl printf_byte
   incl printf_bool
   dependByName "foo"
-  let ivoryMain :: Def('[] ':-> Sint32)
+  let ivoryMain :: Def('[] :-> Sint32)
       ivoryMain = proc "main" $ body $ do
         upTo (0 :: Ix 11) 10 $ \ix -> do
           byteRef <- local (ival (castDefault (fromIx ix)))
           byte <- deref byteRef
           call_ printf_byte "driver in: %u\n" byte
           call_ intermon1_put_data (constRef byteRef)
           zero <- constRef `fmap` local izero
-          call_ (importProc "component_entry" "foo.h" :: Def('[ConstRef s ('Stored Sint64)] ':-> ())) zero
+          call_ (importProc "component_entry" "foo.h" :: Def('[ConstRef s ('Stored Sint64)] :-> ())) zero
           bRef <- local izero
           has_data <- call intermon2_get_data bRef
           ifte_ has_data

tower-mini/tower-mini.cabal

@@ -16,6 +16,7 @@ library
                , filepath
                , mainland-pretty >= 0.4.0.0
                , monadLib
+               , pretty >= 1.1
                , ivory >= 0.1.0.2
                , ivory-backend-c
                , tower

tower/src/Ivory/Tower/Tower.hs

@@ -114,6 +114,6 @@ getTime :: Ivory eff ITime
 getTime = call getTimeProc
   where
   -- Must be provided by the code generator:
-  getTimeProc :: Def('[]':->ITime)
+  getTimeProc :: Def('[]:->ITime)
   getTimeProc = importProc "tower_get_time" "tower_time.h"