OpenAPI (#251): argument types

Pinafore/pinafore-docgen/test/golden/openapi/petstore-expanded.ref

@@ -8,7 +8,7 @@
 
 **<code>functions\.Info\.</code>**<code> : List\. Text\.</code>
 
-**<code>findPets\.</code>**<code> : Text\. \-\> Text\. \-\> Action\. Text\.</code>
+**<code>findPets\.</code>**<code> : List\. Text\. \-\> Integer\. \-\> Action\. Text\.</code>
 
 > Returns all pets from the system that the user has access to
 Nam sed condimentum est. Maecenas tempor sagittis sapien, nec rhoncus sem sagittis sit amet. Aenean at gravida augue, ac iaculis sem. Curabitur odio lorem, ornare eget elementum nec, cursus id lectus. Duis mi turpis, pulvinar ac eros ac, tincidunt varius justo. In hac habitasse platea dictumst. Integer at adipiscing ante, a sagittis ligula. Aenean pharetra tempor ante molestie imperdiet. Vivamus id aliquam diam. Cras quis velit non tortor eleifend sagittis. Praesent at enim pharetra urna volutpat venenatis eget eget mauris. In eleifend fermentum facilisis. Praesent enim enim, gravida ac sodales sed, placerat id erat. Suspendisse lacus dolor, consectetur non augue vel, vehicula interdum libero. Morbi euismod sagittis libero sed lacinia.
@@ -19,11 +19,11 @@ Sed tempus felis lobortis leo pulvinar rutrum. Nam mattis velit nisl, eu condime
 
 > Creates a new pet in the store. Duplicates are allowed
 > 
-**<code>find\_\_pet\_\_by\_\_id\.</code>**<code> : Text\. \-\> Action\. Text\.</code>
+**<code>find\_\_pet\_\_by\_\_id\.</code>**<code> : Integer\. \-\> Action\. Text\.</code>
 
 > Returns a user based on a single ID, if the user does not have access to the pet
 > 
-**<code>deletePet\.</code>**<code> : Text\. \-\> Action\. Text\.</code>
+**<code>deletePet\.</code>**<code> : Integer\. \-\> Action\. Text\.</code>
 
 > deletes a single pet based on the ID supplied
 > 

Pinafore/pinafore-language/lib/Pinafore/Language/Library/Types.hs

@@ -1,6 +1,18 @@
-module Pinafore.Language.Library.Types where
+module Pinafore.Language.Library.Types
+    ( openEntityShimWit
+    , concreteDynamicEntityShimWit
+    , maybeShimWit
+    , listShimWit
+    , list1ShimWit
+    , eitherShimWit
+    , nullShimWit
+    , pairShimWit
+    , funcShimWit
+    , actionShimWit
+    ) where
 
 import Pinafore.Base
+import Pinafore.Language.Convert.Types
 import Pinafore.Language.Library.Convert ()
 import Pinafore.Language.Name
 import Pinafore.Language.Type
@@ -13,20 +25,97 @@ concreteDynamicEntityShimWit :: FullName -> ConcreteDynamicType -> QShimWit 'Pos
 concreteDynamicEntityShimWit n dt =
     typeToDolan $ MkDolanGroundedType (concreteDynamicStorableGroundType n dt) NilCCRArguments
 
-maybeShimWit :: forall a. QShimWit 'Positive a -> QShimWit 'Positive (Maybe a)
-maybeShimWit swa =
-    unPosShimWit swa $ \ta conva ->
-        mapPosShimWit (applyCoPolyShim ccrVariation ccrVariation id conva) $
-        typeToDolan $ MkDolanGroundedType maybeGroundType $ ConsCCRArguments (CoCCRPolarArgument ta) NilCCRArguments
+coFShimWit ::
+       forall f polarity a. (HasVariance f, VarianceOf f ~ Covariance, Is PolarityType polarity)
+    => QGroundType '[ CoCCRVariance] f
+    -> QShimWit polarity a
+    -> QShimWit polarity (f a)
+coFShimWit gt (MkShimWit ta conva) = let
+    fshim =
+        case polarityType @polarity of
+            PositiveType ->
+                case conva of
+                    MkPolarShim shima -> MkPolarShim $ applyCoPolyShim ccrVariation ccrVariation id shima
+            NegativeType ->
+                case conva of
+                    MkPolarShim shima -> MkPolarShim $ applyCoPolyShim ccrVariation ccrVariation id shima
+    in mapPolarShimWit fshim $
+       typeToDolan $ MkDolanGroundedType gt $ ConsCCRArguments (CoCCRPolarArgument ta) NilCCRArguments
 
-eitherShimWit :: forall a b. QShimWit 'Positive a -> QShimWit 'Positive b -> QShimWit 'Positive (Either a b)
-eitherShimWit swa swb =
-    unPosShimWit swa $ \ta conva ->
-        unPosShimWit swb $ \tb convb ->
-            mapPosShimWit (applyCoPolyShim ccrVariation ccrVariation (cfmap conva) convb) $
-            typeToDolan $
-            MkDolanGroundedType eitherGroundType $
-            ConsCCRArguments (CoCCRPolarArgument ta) $ ConsCCRArguments (CoCCRPolarArgument tb) NilCCRArguments
+maybeShimWit ::
+       forall polarity a. Is PolarityType polarity
+    => QShimWit polarity a
+    -> QShimWit polarity (Maybe a)
+maybeShimWit = coFShimWit maybeGroundType
+
+listShimWit ::
+       forall polarity a. Is PolarityType polarity
+    => QShimWit polarity a
+    -> QShimWit polarity [a]
+listShimWit = coFShimWit listGroundType
+
+list1ShimWit ::
+       forall polarity a. Is PolarityType polarity
+    => QShimWit polarity a
+    -> QShimWit polarity (NonEmpty a)
+list1ShimWit = coFShimWit list1GroundType
+
+cocoFShimWit ::
+       forall f polarity a b. Is PolarityType polarity
+    => QGroundType '[ CoCCRVariance, CoCCRVariance] f
+    -> QShimWit polarity a
+    -> QShimWit polarity b
+    -> QShimWit polarity (f a b)
+cocoFShimWit gt (MkShimWit ta conva) (MkShimWit tb convb) = let
+    fshim =
+        case qgtVarianceMap gt of
+            ConsCCRVariancesMap ccrva mapb ->
+                case polarityType @polarity of
+                    PositiveType ->
+                        case (conva, convb) of
+                            (MkPolarShim (shima :: _ x y), MkPolarShim shimb) ->
+                                MkPolarShim $
+                                applyCoPolyShim
+                                    (case mapb of
+                                         ConsCCRVariancesMap ccrvb NilCCRVariancesMap -> ccrvb)
+                                    (case mapb of
+                                         ConsCCRVariancesMap ccrvb NilCCRVariancesMap -> ccrvb)
+                                    (applyCoPolyShim ccrva ccrva id shima)
+                                    shimb
+                    NegativeType ->
+                        case (conva, convb) of
+                            (MkPolarShim (shima :: _ x y), MkPolarShim shimb) ->
+                                MkPolarShim $
+                                applyCoPolyShim
+                                    (case mapb of
+                                         ConsCCRVariancesMap ccrvb NilCCRVariancesMap -> ccrvb)
+                                    (case mapb of
+                                         ConsCCRVariancesMap ccrvb NilCCRVariancesMap -> ccrvb)
+                                    (applyCoPolyShim ccrva ccrva id shima)
+                                    shimb
+    in mapPolarShimWit fshim $
+       typeToDolan $
+       MkDolanGroundedType gt $
+       ConsCCRArguments (CoCCRPolarArgument ta) $ ConsCCRArguments (CoCCRPolarArgument tb) NilCCRArguments
+
+eitherShimWit ::
+       forall polarity a b. Is PolarityType polarity
+    => QShimWit polarity a
+    -> QShimWit polarity b
+    -> QShimWit polarity (Either a b)
+eitherShimWit = cocoFShimWit eitherGroundType
+
+nullShimWit ::
+       forall polarity. Is PolarityType polarity
+    => QShimWit polarity ()
+nullShimWit = typeToDolan $ MkDolanGroundedType unitGroundType NilCCRArguments
+
+pairShimWit ::
+       forall polarity a b. Is PolarityType polarity
+    => QShimWit polarity a
+    -> QShimWit polarity b
+    -> QShimWit polarity (a, b)
+pairShimWit = cocoFShimWit pairGroundType
 
 funcShimWit ::
        forall polarity (pshim :: PolyShimKind) a b.

Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs

@@ -102,18 +102,50 @@ showOperation op = do
 data Func r where
     MkFunc :: QShimWit 'Positive t -> ((Object -> IO r) -> t) -> Func r
 
-mkParam :: Param -> QShimWit 'Negative Value
-mkParam _ = mapShimWit (MkPolarShim $ functionToShim "param" String) qType
-
-mkFunc :: QShimWit 'Positive r -> [Param] -> Func r
-mkFunc tr [] = MkFunc (actionShimWit tr) $ \call -> liftIO $ call mempty
-mkFunc tr (p:pp) =
-    case mkParam p of
-        MkShimWit ta (MkPolarShim pf) ->
-            case mkFunc tr pp of
-                MkFunc tf f ->
-                    MkFunc (funcShimWit (mkShimWit ta) tf) $ \call a ->
-                        f $ \obj -> call $ Aeson.insert (Aeson.fromText $ _paramName p) (shimToFunction pf a) obj
+tupleParamList :: [QShimWit 'Negative Value] -> QShimWit 'Negative [Value]
+tupleParamList (w:ww) = mapNegShimWit (functionToShim "cons" $ \(a, aa) -> a : aa) $ pairShimWit w (tupleParamList ww)
+tupleParamList [] = mapNegShimWit (functionToShim "nil" $ \() -> []) nullShimWit
+
+mkParam :: Schema -> M (QShimWit 'Negative Value)
+mkParam Schema {..}
+    | Just t <- _schemaType =
+        case t of
+            OpenApiArray -> do
+                items <- maybeToM "missing _schemaItems" _schemaItems
+                itemlist <-
+                    case items of
+                        OpenApiItemsObject rs -> do
+                            itemschema <- getReferenced rs
+                            itemp <- mkParam itemschema
+                            return $ listShimWit itemp
+                        OpenApiItemsArray rss -> do
+                            pp <-
+                                for rss $ \rs -> do
+                                    itemschema <- getReferenced rs
+                                    mkParam itemschema
+                            return $ tupleParamList pp
+                return $ mapNegShimWit (functionToShim "JSON.Array" $ Array . fromList) itemlist
+            OpenApiString -> return $ mapNegShimWit (functionToShim "JSON.String" String) qType
+            OpenApiInteger -> return $ mapNegShimWit (functionToShim "JSON.Number" $ Number . fromInteger) qType
+            OpenApiBoolean -> return $ mapNegShimWit (functionToShim "JSON.Bool" Bool) qType
+            OpenApiNull -> return $ mapNegShimWit (functionToShim "JSON.Null" $ \() -> Null) qType
+            _ -> throwExc $ "unknown _schemaType: " <> showText t
+mkParam _ = throwExc "missing _schemaType"
+
+mkFunc :: QShimWit 'Positive r -> [Param] -> M (Func r)
+mkFunc tr [] = return $ MkFunc (actionShimWit tr) $ \call -> liftIO $ call mempty
+mkFunc tr (p:pp) = do
+    ref <- maybeToM "missing _paramSchema" $ _paramSchema p
+    sch <- getReferenced ref
+    pw <- mkParam sch
+    func <- mkFunc tr pp
+    return $
+        case pw of
+            MkShimWit ta (MkPolarShim pf) ->
+                case func of
+                    MkFunc tf f ->
+                        MkFunc (funcShimWit (mkShimWit ta) tf) $ \call a ->
+                            f $ \obj -> call $ Aeson.insert (Aeson.fromText $ _paramName p) (shimToFunction pf a) obj
 
 importOpenAPI :: Text -> ResultT Text IO (LibraryStuff ())
 importOpenAPI t = do
@@ -135,9 +167,8 @@ importOpenAPI t = do
         mkOperationFunction :: (Operation, Text, Text) -> M (LibraryStuff ())
         mkOperationFunction (op, opname, path) = do
             (name, params) <- operationToFunction op
+            func <- mkFunc qType params
             let
-                func :: Func Text
-                func = mkFunc qType params
                 call :: Object -> IO Text
                 call _ = return $ opname <> " " <> path
             return $