OpenAPI (#251): work on operation arguments

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

@@ -8,22 +8,22 @@
 
 **<code>functions\.Info\.</code>**<code> : List\. Text\.</code>
 
-**<code>findPets\.</code>**<code> : Text\.</code>
+**<code>findPets\.</code>**<code> : Text\. \-\> Text\. \-\> 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.
 > 
 Sed tempus felis lobortis leo pulvinar rutrum. Nam mattis velit nisl, eu condimentum ligula luctus nec. Phasellus semper velit eget aliquet faucibus. In a mattis elit. Phasellus vel urna viverra, condimentum lorem id, rhoncus nibh. Ut pellentesque posuere elementum. Sed a varius odio. Morbi rhoncus ligula libero, vel eleifend nunc tristique vitae. Fusce et sem dui. Aenean nec scelerisque tortor. Fusce malesuada accumsan magna vel tempus. Quisque mollis felis eu dolor tristique, sit amet auctor felis gravida. Sed libero lorem, molestie sed nisl in, accumsan tempor nisi. Fusce sollicitudin massa ut lacinia mattis. Sed vel eleifend lorem. Pellentesque vitae felis pretium, pulvinar elit eu, euismod sapien.
 > 
-**<code>addPet\.</code>**<code> : Text\.</code>
+**<code>addPet\.</code>**<code> : Action\. Text\.</code>
 
 > Creates a new pet in the store. Duplicates are allowed
 > 
-**<code>find\_\_pet\_\_by\_\_id\.</code>**<code> : Text\.</code>
+**<code>find\_\_pet\_\_by\_\_id\.</code>**<code> : Text\. \-\> 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\.</code>
+**<code>deletePet\.</code>**<code> : Text\. \-\> Action\. Text\.</code>
 
 > deletes a single pet based on the ID supplied
 > 

Pinafore/pinafore-language/lib/Pinafore/Language/API.hs

@@ -3,6 +3,7 @@ module Pinafore.Language.API
     , module Pinafore.Language.Name
     , module Pinafore.Language.Var
     , module Pinafore.Language.Library.Defs
+    , module Pinafore.Language.Library.Types
     , module Pinafore.Context
     , WitKind(..)
     , FamilialType(..)
@@ -11,6 +12,7 @@ module Pinafore.Language.API
     , StorableGroundType(..)
     , FamilyKind
     , SingletonFamily
+    , QShimWit
     , QGroundType(..)
     , PolyGreatestDynamicSupertype(..)
     , simpleMPolyGreatestDynamicSupertype
@@ -45,6 +47,7 @@ import Pinafore.Language.Library.Defs
 import Pinafore.Language.Library.Interpret
 import Pinafore.Language.Library.MIME ()
 import Pinafore.Language.Library.Model ()
+import Pinafore.Language.Library.Types
 import Pinafore.Language.Name
 import Pinafore.Language.Shim
 import Pinafore.Language.Type

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

@@ -14,6 +14,7 @@ module Pinafore.Language.Library.Defs
     , headingBDT
     , headingBDS
     , namespaceBDS
+    , valWitBDS
     , valBDS
     , typeBDS
     , subtypeRelationBDS
@@ -94,6 +95,9 @@ instance Contravariant LibraryModule where
 
 type EnA = MeetType Entity A
 
+qPositiveShimWitDescription :: forall t. QShimWit 'Positive t -> NamedText
+qPositiveShimWitDescription (MkShimWit w _) = exprShow w
+
 qPositiveTypeDescription ::
        forall t. HasQType 'Positive t
     => NamedText
@@ -162,24 +166,33 @@ headingBDS name desc tree = pureForest $ headingBDT name desc tree
 namespaceBDS :: NamespaceRef -> [LibraryStuff context] -> LibraryStuff context
 namespaceBDS name tree = namespaceConcat name $ mconcat tree
 
-valBDS ::
-       forall context t. HasQType 'Positive t
-    => FullNameRef
+valWitBDS ::
+       forall context t.
+       FullNameRef
     -> RawMarkdown
+    -> QShimWit 'Positive t
     -> ((?qcontext :: context) => t)
     -> LibraryStuff context
-valBDS name docDescription val = let
+valWitBDS name docDescription qt val = let
     bdScopeEntry =
         pure $
         BindScopeEntry name [] $ \context -> let
             ?qcontext = context
-            in ValueBinding (qConstExprAny $ jmToValue val) Nothing
+            in ValueBinding (qConstExprAny $ MkSomeOf qt val) Nothing
     diNames = pure name
-    diType = qPositiveTypeDescription @t
+    diType = qPositiveShimWitDescription qt
     docItem = ValueDocItem {..}
     bdDoc = MkDefDoc {..}
     in singleBindDoc MkBindDoc {..} []
 
+valBDS ::
+       forall context t. HasQType 'Positive t
+    => FullNameRef
+    -> RawMarkdown
+    -> ((?qcontext :: context) => t)
+    -> LibraryStuff context
+valBDS name docDescription = valWitBDS name docDescription qType
+
 newTypeParameter :: State [Name] Name
 newTypeParameter = do
     nn <- get

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

@@ -2,9 +2,12 @@ module Pinafore.WebAPI.OpenAPI
     ( openAPIImporter
     ) where
 
-import Data.Aeson hiding (Result)
+import Data.Aeson as Aeson hiding (Result)
+import qualified Data.Aeson.Key as Aeson
+import qualified Data.Aeson.KeyMap as Aeson
 import qualified Data.HashMap.Strict.InsOrd as InsOrd
 import Data.OpenApi hiding (items, name)
+import Data.Shim
 import Pinafore.Language
 import Pinafore.Language.API
 import Pinafore.WebAPI.Fetch
@@ -96,6 +99,22 @@ showOperation op = do
     (opid, params) <- operationToFunction op
     return $ showText opid <> "(" <> intercalate ", " (fmap showParam params) <> ")"
 
+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
+
 importOpenAPI :: Text -> ResultT Text IO (LibraryStuff ())
 importOpenAPI t = do
     bs <- fetch t
@@ -117,9 +136,18 @@ importOpenAPI t = do
         mkOperationFunction (op, opname, path) = do
             (name, params) <- operationToFunction op
             let
-                val :: Text
-                val = "(" <> intercalate ", " (fmap showParam params) <> ")" <> " = " <> opname <> " " <> path
-            return $ valBDS (UnqualifiedFullNameRef name) (MkRawMarkdown $ fromMaybe "" $ _operationDescription op) val
+                func :: Func Text
+                func = mkFunc qType params
+                call :: Object -> IO Text
+                call _ = return $ opname <> " " <> path
+            return $
+                case func of
+                    MkFunc qt f ->
+                        valWitBDS
+                            (UnqualifiedFullNameRef name)
+                            (MkRawMarkdown $ fromMaybe "" $ _operationDescription op)
+                            qt $
+                        f call
     functions <- runM $ for operations mkOperationFunction
     return $
         mconcat $

Pinafore/pinafore-webapi/package.yaml

@@ -14,6 +14,7 @@ library:
       - aeson
       - openapi3
       - shapes
+      - polar-shim
       - pinafore-language
     exposed-modules:
       - Pinafore.WebAPI

Pinafore/pinafore-webapi/pinafore-webapi.cabal

@@ -56,6 +56,7 @@ library
     , network-uri
     , openapi3
     , pinafore-language
+    , polar-shim
     , shapes
   default-language: GHC2021