make conversion functions for input ports optional

compiler/Generate/JavaScript.hs

@@ -197,8 +197,10 @@ expression (L span expr) =
             md = pad ++ MD.toHtml doc ++ pad
 
       PortIn name _ _ handler ->
-          do handler' <- expression handler
-             return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]
+          do handler' <- case handler of
+                           Nothing -> return []
+                           Just h -> (:[]) `fmap` expression h
+             return $ obj "Native.Ports.portIn" `call` ([ string name ] ++ handler')
 
       PortOut name _ signal ->
           do signal' <- expression signal

compiler/SourceSyntax/Declaration.hs

@@ -29,7 +29,7 @@ data ParsePort
 
 data Port
     = Out String Expr.LExpr T.Type
-    | In String Expr.LExpr T.Type
+    | In String (Maybe Expr.LExpr) T.Type
       deriving (Show)
 
 type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
@@ -108,7 +108,10 @@ instance Pretty Port where
   pretty port =
     case port of
       Out name expr tipe -> mkPort "<-" name expr tipe
-      In name expr tipe -> mkPort "->" name expr tipe
+      In name mexpr tipe ->
+          case mexpr of
+            Nothing   -> prettyPort name ":" tipe
+            Just expr -> mkPort "->" name expr tipe
     where
       mkPort arrow name expr tipe = 
           P.vcat [ prettyPort name ":" tipe

compiler/SourceSyntax/Expression.hs

@@ -40,7 +40,7 @@ data Expr' def
     | Record [(String, LExpr' def)]
     | Markdown String String [LExpr' def]
     -- for type checking and code gen only
-    | PortIn String SrcType.Type Type.Variable (LExpr' def)
+    | PortIn String SrcType.Type Type.Variable (Maybe (LExpr' def))
     | PortOut String SrcType.Type (LExpr' def)
 
 type ParseExpr = Expr' ParseDef
@@ -129,7 +129,7 @@ instance Pretty def => Pretty (Expr' def) where
 
      Markdown _ _ _ -> P.text "[markdown| ... |]"
 
-     PortIn _ _ _ handler -> pretty handler
+     PortIn _ _ _ _ -> P.text "<port in>"
 
      PortOut _ _ signal -> pretty signal
 

compiler/Transform/Canonicalize.hs

@@ -4,6 +4,7 @@ module Transform.Canonicalize (interface, metadataModule) where
 import Control.Arrow ((***))
 import Control.Applicative (Applicative,(<$>),(<*>))
 import Control.Monad.Identity
+import Data.Traversable (traverse)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -169,7 +170,7 @@ rename env (L s expr) =
 
       PortIn name st tt handler ->
           do st' <- renameType' env st
-             handler' <- rnm handler
+             handler' <- traverse rnm handler
              return $ PortIn name st' tt handler'
 
       PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

compiler/Transform/Check.hs

@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -Wall #-}
 module Transform.Check (mistakes) where
 
+import qualified Control.Arrow as Arrow
 import qualified Data.List as List
 import qualified Data.Maybe as Maybe
 import qualified Data.Set as Set
@@ -44,10 +45,11 @@ duplicates decls =
         unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]
 
     (portNames, portExprs) =
-        unzip $ flip map [ port | D.Port port <- decls ] $ \port ->
+        Arrow.second Maybe.catMaybes $ unzip $ 
+        flip map [ port | D.Port port <- decls ] $ \port ->
             case port of
-              D.Out name expr _ -> (name,expr)
-              D.In name expr _ -> (name,expr)
+              D.Out name expr _ -> (name, Just expr)
+              D.In name expr _ -> (name, expr)
 
     getNames = Set.toList . Pattern.boundVars
 

compiler/Transform/Declaration.hs

@@ -62,6 +62,7 @@ combineAnnotations = go
 
                         Port (PPIn name' expr) : rest | name == name' ->
                             do expr' <- exprCombineAnnotations expr
-                               (:) (Port (In name expr' tipe)) <$> go rest
+                               (:) (Port (In name (Just expr') tipe)) <$> go rest
+
+                        _ -> (:) (Port (In name Nothing tipe)) <$> go portRest
 
-                        _ -> Left (msg name)

compiler/Transform/Expression.hs

@@ -2,6 +2,7 @@
 module Transform.Expression (crawlLet, checkPorts) where
 
 import Control.Applicative ((<$>),(<*>))
+import Data.Traversable (traverse)
 import SourceSyntax.Expression
 import SourceSyntax.Location
 import qualified SourceSyntax.Type as ST
@@ -50,7 +51,7 @@ crawl portInCheck portOutCheck defsTransform = go
             Let defs body -> Let <$> defsTransform defs <*> go body
             PortIn name st tt handler ->
                 do portInCheck name st tt
-                   PortIn name st tt <$> go handler
+                   PortIn name st tt <$> traverse go handler
             PortOut name st signal ->
                 do portOutCheck name st
                    PortOut name st <$> go signal

compiler/Transform/SafeNames.hs

@@ -49,7 +49,7 @@ expression (L loc expr) =
       Modify r fs -> Modify (f r) (map (var *** f) fs)
       Record fs -> Record (map (var *** f) fs)
       Markdown uid md es -> Markdown uid md (map f es)
-      PortIn name st tt handler -> PortIn name st tt (f handler)
+      PortIn name st tt handler -> PortIn name st tt (fmap f handler)
       PortOut name st signal -> PortOut name st (f signal)
 
 definition :: Def -> Def

compiler/Transform/SortDefinitions.hs

@@ -3,6 +3,7 @@ module Transform.SortDefinitions (sortDefs) where
 
 import Control.Monad.State
 import Control.Applicative ((<$>),(<*>))
+import Data.Traversable (traverse)
 import qualified Data.Map as Map
 import SourceSyntax.Expression
 import SourceSyntax.Location
@@ -85,7 +86,8 @@ reorder (L s expr) =
 
       PortOut name st signal -> PortOut name st <$> reorder signal
 
-      PortIn name st tt handler -> PortIn name st tt <$> reorder handler
+      PortIn name st tt handler ->
+          PortIn name st tt <$> traverse reorder handler
 
       -- Actually do some reordering
       Let defs body ->

compiler/Transform/Substitute.hs

@@ -38,5 +38,5 @@ subst old new expr =
       Record fs -> Record (map (second f) fs)
       Literal _ -> expr
       Markdown uid md es -> Markdown uid md (map f es)
-      PortIn name st tt handler -> PortIn name st tt (f handler)
+      PortIn name st tt handler -> PortIn name st tt (fmap f handler)
       PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Constrain/Declaration.hs

@@ -49,10 +49,14 @@ toDefs decl =
         case port of
           Out name expr@(L.L s _) tipe ->
               [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
-          In name expr@(L.L s _) tipe ->
+          In name mexpr tipe ->
               unsafePerformIO $ do
                 tvar <- Type.var Type.Flexible
-                return $ [ definition name (L.L s $ E.PortIn name tipe tvar expr) tipe ]
+                return $ [ definition name (loc $ E.PortIn name tipe tvar mexpr) tipe ]
+              where
+                loc = case mexpr of
+                        Just (L.L s _) -> L.L s
+                        Nothing -> L.none
 
     -- no constraints are needed for fixity declarations
     Fixity _ _ _ -> []

compiler/Type/Constrain/Expression.hs

@@ -3,6 +3,7 @@ module Type.Constrain.Expression where
 
 import qualified Data.List as List
 import qualified Data.Map as Map
+import qualified Data.Maybe as Maybe
 import qualified Data.Set as Set
 import Control.Applicative ((<$>))
 import qualified Control.Monad as Monad
@@ -147,7 +148,9 @@ constrain env (L span expr) tipe =
                                  (c1 /\ c))
 
       PortIn _ _ tt handler ->
-          constrain env handler (VarN tt)
+          constrain env (Maybe.fromMaybe identity handler) (VarN tt)
+          where
+            identity = Loc.none $ Lambda (PVar "x") (Loc.none $ Var "x")
 
       PortOut _ _ signal ->
           constrain env signal tipe