Support task ports with optional input.

Author: robinheghan

compiler/src/AST/Canonical.hs

@@ -266,7 +266,7 @@ data Effects
 data Port
   = Incoming {_freeVars :: FreeVars, _payload :: Type, _func :: Type}
   | Outgoing {_freeVars :: FreeVars, _payload :: Type, _func :: Type}
-  | Task {_freeVars :: FreeVars, _payload :: Type, _func :: Type}
+  | Task {_freeVars :: FreeVars, _input :: Maybe Type, _payload :: Type, _func :: Type}
   deriving (Show)
 
 data Manager

compiler/src/AST/Optimized.hs

@@ -142,7 +142,7 @@ data Node
   | Kernel [K.Chunk] (Set.Set Global)
   | PortIncoming Expr (Set.Set Global)
   | PortOutgoing Expr (Set.Set Global)
-  | PortTask Expr (Set.Set Global)
+  | PortTask (Maybe Expr) Expr (Set.Set Global)
 
 data EffectsType = Cmd | Sub | Fx
 
@@ -374,7 +374,7 @@ instance Binary Node where
       Kernel a b -> putWord8 8 >> put a >> put b
       PortIncoming a b -> putWord8 9 >> put a >> put b
       PortOutgoing a b -> putWord8 10 >> put a >> put b
-      PortTask a b -> putWord8 11 >> put a >> put b
+      PortTask a b c -> putWord8 11 >> put a >> put b >> put c
 
   get =
     do
@@ -391,7 +391,7 @@ instance Binary Node where
         8 -> liftM2 Kernel get get
         9 -> liftM2 PortIncoming get get
         10 -> liftM2 PortOutgoing get get
-        11 -> liftM2 PortTask get get
+        11 -> liftM3 PortTask get get get
         _ -> fail "problem getting Opt.Node binary"
 
 instance Binary EffectsType where

compiler/src/Canonicalize/Effects.hs

@@ -101,7 +101,7 @@ canonicalizePort env (Src.Port (A.At region portName) tipe) =
                     Result.throw (Error.PortTypeInvalid region portName Error.SubBad)
               _ ->
                 Result.throw (Error.PortTypeInvalid region portName Error.SubBad)
-      [Can.TType home name taskArgs]
+      Can.TType home name taskArgs : tipes
         | home == ModuleName.platform && name == Name.task ->
             case taskArgs of
               [] ->
@@ -111,7 +111,18 @@ canonicalizePort env (Src.Port (A.At region portName) tipe) =
               [errorType, incomingType] ->
                 case (checkTaskError errorType, checkPayload incomingType) of
                   (True, Right ()) ->
-                    Result.ok (portName, Can.Task freeVars incomingType ctipe)
+                    case tipes of
+                      [] ->
+                        Result.ok (portName, Can.Task freeVars Nothing incomingType ctipe)
+                      [input] ->
+                        case checkPayload input of
+                          Right () ->
+                            -- TODO:
+                            Result.ok (portName, Can.Task freeVars (Just input) incomingType ctipe)
+                          Left (badType, err) ->
+                            Result.throw (Error.PortPayloadInvalid region portName badType err)
+                      _ ->
+                        Result.throw (Error.PortTypeInvalid region portName (Error.TaskExtraInputs (length tipes)))
                   (False, _) ->
                     Result.throw (Error.PortTypeInvalid region portName Error.TaskBadError)
                   (_, Left (badType, err)) ->

compiler/src/Generate/JavaScript.hs

@@ -230,10 +230,10 @@ addGlobalHelp mode graph global@(Opt.Global home _) state =
             (addDeps deps state)
             ( generatePort mode global "outgoingPort" encoder
             )
-        Opt.PortTask decoder deps ->
+        Opt.PortTask maybeEncoder decoder deps ->
           addStmt
             (addDeps deps state)
-            ( generatePort mode global "taskPort" decoder
+            ( generateTaskPort mode global maybeEncoder decoder
             )
 
 addStmt :: State -> JS.Stmt -> State
@@ -411,6 +411,30 @@ generatePort mode (Opt.Global home name) makePort converter =
         Expr.codeToExpr (Expr.generate mode (\_ _ -> Nothing) home converter)
       ]
 
+generateTaskPort :: Mode.Mode -> Opt.Global -> Maybe Opt.Expr -> Opt.Expr -> JS.Stmt
+generateTaskPort mode (Opt.Global home name) maybeInputConverter outputConverter =
+  JS.Var
+    (JsName.fromGlobal home name)
+    ( case maybeInputConverter of
+        Nothing ->
+          JS.Call
+            ( JS.Call
+                (JS.Ref (JsName.fromKernel Name.platform "taskPort"))
+                [ JS.String (Name.toBuilder name),
+                  JS.Null,
+                  Expr.codeToExpr (Expr.generate mode (\_ _ -> Nothing) home outputConverter)
+                ]
+            )
+            [JS.Null]
+        Just inputConverter ->
+          JS.Call
+            (JS.Ref (JsName.fromKernel Name.platform "taskPort"))
+            [ JS.String (Name.toBuilder name),
+              Expr.codeToExpr (Expr.generate mode (\_ _ -> Nothing) home inputConverter),
+              Expr.codeToExpr (Expr.generate mode (\_ _ -> Nothing) home outputConverter)
+            ]
+    )
+
 -- GENERATE MANAGER
 
 generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State

compiler/src/Optimize/Module.hs

@@ -103,9 +103,16 @@ addPort home name port_ graph =
       let (deps, fields, encoder) = Names.run (Port.toEncoder payloadType)
           node = Opt.PortOutgoing encoder deps
        in addToGraph (Opt.Global home name) node fields graph
-    Can.Task _ payloadType _ ->
+    Can.Task _ Nothing payloadType _ ->
       let (deps, fields, decoder) = Names.run (Port.toDecoder payloadType)
-          node = Opt.PortTask decoder deps
+          node = Opt.PortTask Nothing decoder deps
+       in addToGraph (Opt.Global home name) node fields graph
+    Can.Task _ (Just inputType) payloadType _ ->
+      let (payloadDeps, payloadFields, decoder) = Names.run (Port.toDecoder payloadType)
+          (inputDeps, inputFields, encoder) = Names.run (Port.toEncoder inputType)
+          deps = Set.union payloadDeps inputDeps
+          fields = Map.unionWith (+) payloadFields inputFields
+          node = Opt.PortTask (Just encoder) decoder deps
        in addToGraph (Opt.Global home name) node fields graph
 
 -- HELPER

compiler/src/Reporting/Error/Canonicalize.hs

@@ -97,6 +97,7 @@ data PortProblem
   | TaskNoArg
   | TaskOneArg
   | TaskExtraArgs Int
+  | TaskExtraInputs Int
   | TaskBadError
   | TaskBadPayload
   | NotCmdOrSub
@@ -657,6 +658,11 @@ toReport source err =
                   D.reflow
                     "`Task` only accepts two arguments: the error type and the success type."
                 )
+              TaskExtraInputs num ->
+                ( "The `" <> Name.toChars name <> "` port is defined with too many function arguments (" <> show num <> ").",
+                  D.reflow
+                    "A task-based port can accept at most 1 argument."
+                )
               TaskBadError ->
                 ( "The `"
                     <> Name.toChars name

compiler/src/Type/Constrain/Module.hs

@@ -70,7 +70,7 @@ letPort name port_ makeConstraint =
         tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType
         let header = Map.singleton name (A.At A.zero tipe)
         CLet (Map.elems vars) [] header CTrue <$> makeConstraint
-    Can.Task freeVars _ srcType ->
+    Can.Task freeVars _ _ srcType ->
       do
         vars <- Map.traverseWithKey (\k _ -> nameToRigid k) freeVars
         tipe <- Instantiate.fromSrcType (Map.map VarN vars) srcType