diff --git a/Pinafore/pinafore-docgen/test/golden/openapi/petstore-expanded.ref b/Pinafore/pinafore-docgen/test/golden/openapi/petstore-expanded.ref index 72c6b1993..d4bab5f12 100644 --- a/Pinafore/pinafore-docgen/test/golden/openapi/petstore-expanded.ref +++ b/Pinafore/pinafore-docgen/test/golden/openapi/petstore-expanded.ref @@ -8,7 +8,7 @@ **functions\.Info\.** : List\. Text\. -**findPets\.** : Text\. \-\> Text\. \-\> Action\. Text\. +**findPets\.** : List\. Text\. \-\> Integer\. \-\> Action\. Text\. > 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 > -**find\_\_pet\_\_by\_\_id\.** : Text\. \-\> Action\. Text\. +**find\_\_pet\_\_by\_\_id\.** : Integer\. \-\> Action\. Text\. > Returns a user based on a single ID, if the user does not have access to the pet > -**deletePet\.** : Text\. \-\> Action\. Text\. +**deletePet\.** : Integer\. \-\> Action\. Text\. > deletes a single pet based on the ID supplied > diff --git a/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Types.hs b/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Types.hs index adafc425b..b6d47c5e3 100644 --- a/Pinafore/pinafore-language/lib/Pinafore/Language/Library/Types.hs +++ b/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. diff --git a/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs b/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs index 6d41160d3..1f42fd476 100644 --- a/Pinafore/pinafore-webapi/lib/Pinafore/WebAPI/OpenAPI.hs +++ 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 $