Improvements to inlining behavior

digitallyinduced · Dec 3, 2020 · c70cd27 · c70cd27
1 parent b36350f
commit c70cd27
Show file tree

Hide file tree

Showing 9 changed files with 90 additions and 83 deletions.
diff --git a/IHP/Controller/Context.hs b/IHP/Controller/Context.hs
@@ -53,14 +53,15 @@ newControllerContext :: (?requestContext :: RequestContext) => IO ControllerCont
 newControllerContext = do
     customFieldsRef <- newIORef TypeMap.empty
     pure ControllerContext { requestContext = ?requestContext, customFieldsRef }
-{-# INLINE newControllerContext #-}
+{-# INLINABLE newControllerContext #-}
 
 -- | After freezing a container you can access it's values from pure non-IO code by using 'fromFronzenContext'
 --
 -- Calls to 'putContext' will throw an exception after it's frozen.
 freeze :: ControllerContext -> IO ControllerContext
 freeze ControllerContext { requestContext, customFieldsRef } = FrozenControllerContext requestContext <$> readIORef customFieldsRef
 freeze frozen = pure frozen
+{-# INLINABLE freeze #-}
 
 -- | Returns a value from the current controller context
 --
@@ -78,7 +79,7 @@ fromContext = maybeFromContext @value >>= \case
             let notFoundMessage = ("Unable to find " <> (show (Typeable.typeRep (Typeable.Proxy @value))) <> " in controller context: " <> show customFields)
 
             error notFoundMessage
-{-# INLINE fromContext #-}
+{-# INLINABLE fromContext #-}
 
 -- | Returns a value from the current controller context. Requires the context to be frozen.
 --
@@ -93,20 +94,20 @@ fromFrozenContext = case maybeFromFrozenContext @value of
             let notFoundMessage = ("Unable to find " <> (show (Typeable.typeRep (Typeable.Proxy @value))) <> " in controller context: " <> show customFields)
 
             error notFoundMessage
-{-# INLINE fromFrozenContext #-}
+{-# INLINABLE fromFrozenContext #-}
 
 maybeFromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO (Maybe value)
 maybeFromContext = do
     frozen <- freeze ?context
     let ?context = frozen
     pure (maybeFromFrozenContext @value)
-{-# INLINE maybeFromContext #-}
+{-# INLINABLE maybeFromContext #-}
 
 maybeFromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => Maybe value
 maybeFromFrozenContext = case ?context of
         FrozenControllerContext { customFields } -> TypeMap.lookup @value customFields
         ControllerContext {} -> error ("maybeFromFrozenContext called on a non frozen context while trying to access " <> (show (Typeable.typeRep (Typeable.Proxy @value))))
-{-# INLINE maybeFromFrozenContext #-}
+{-# INLINABLE maybeFromFrozenContext #-}
 
 -- | Puts a value into the context
 --
@@ -116,9 +117,10 @@ putContext value = do
     let ControllerContext { customFieldsRef } = ?context
     modifyIORef customFieldsRef (TypeMap.insert value)
     pure ()
-{-# INLINE putContext #-}
+{-# INLINABLE putContext #-}
 
 newtype ActionType = ActionType Typeable.TypeRep
 
 instance ConfigProvider ControllerContext where
-    getFrameworkConfig context = getFrameworkConfig (get #requestContext context)
+    getFrameworkConfig context = getFrameworkConfig (get #requestContext context)
+    {-# INLINABLE getFrameworkConfig #-}
diff --git a/IHP/Controller/Param.hs b/IHP/Controller/Param.hs
@@ -90,7 +90,7 @@ param :: (?context :: ControllerContext) => (ParamReader valueType) => ByteStrin
 param !name = case paramOrError name of
         Left exception -> Exception.throw exception
         Right value -> value
-{-# INLINE param #-}
+{-# INLINABLE param #-}
 
 -- | Similiar to 'param' but works with multiple params. Useful when working with checkboxes.
 --
@@ -119,7 +119,7 @@ paramList name =
     |> map (readParameter @valueType)
     |> map (Either.fromRight (error (paramParserErrorMessage name)))
     |> DeepSeq.force
-{-# INLINE paramList #-}
+{-# INLINABLE paramList #-}
 
 paramParserErrorMessage name = "param: Parameter '" <> cs name <> "' is invalid"
 
@@ -173,7 +173,7 @@ paramUUID = param @UUID
 -- This will render @Please provide your firstname@ because @hasParam "firstname"@ returns @False@
 hasParam :: (?context :: ControllerContext) => ByteString -> Bool
 hasParam = isJust . queryOrBodyParam
-{-# INLINE hasParam #-}
+{-# INLINABLE hasParam #-}
 
 -- | Like 'param', but returns a default value when the parameter is missing instead of throwing
 -- an exception.
@@ -190,7 +190,7 @@ hasParam = isJust . queryOrBodyParam
 -- When calling @GET /Users?page=1@ the variable @page@ will be set to @1@.
 paramOrDefault :: (?context :: ControllerContext) => ParamReader a => a -> ByteString -> a
 paramOrDefault !defaultValue = fromMaybe defaultValue . paramOrNothing
-{-# INLINE paramOrDefault #-}
+{-# INLINABLE paramOrDefault #-}
 
 -- | Like 'param', but returns @Nothing@ the parameter is missing instead of throwing
 -- an exception.
@@ -211,7 +211,7 @@ paramOrNothing !name =
         Left ParamNotFoundException {} -> Nothing
         Left otherException -> Exception.throw otherException
         Right value -> value
-{-# INLINE paramOrNothing #-}
+{-# INLINABLE paramOrNothing #-}
 
 -- | Like 'param', but returns @Left "Some error message"@ if the parameter is missing or invalid
 paramOrError :: forall paramType. (?context :: ControllerContext) => ParamReader paramType => ByteString -> Either ParamException paramType
@@ -230,12 +230,12 @@ paramOrError !name =
                         Left parserError -> Left ParamCouldNotBeParsedException { name, parserError }
                         Right value -> Right value
                 _ -> Left ParamNotFoundException { name }
-{-# INLINE paramOrError #-}
+{-# INLINABLE paramOrError #-}
 
 -- | Returns a parameter without any parsing. Returns @Nothing@ when the parameter is missing.
 queryOrBodyParam :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
 queryOrBodyParam !name = join (lookup name allParams)
-{-# INLINE queryOrBodyParam #-}
+{-# INLINABLE queryOrBodyParam #-}
 
 -- | Returns all params available in the current request
 allParams :: (?context :: ControllerContext) => [(ByteString, Maybe ByteString)]
@@ -254,14 +254,14 @@ class ParamReader a where
     readParameterJSON :: Aeson.Value -> Either ByteString a
 
 instance ParamReader ByteString where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString = pure byteString
 
     readParameterJSON (Aeson.String bytestring) = Right (cs bytestring)
     readParameterJSON _ = Left "ParamReader ByteString: Expected String"
 
 instance ParamReader Int where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         case Attoparsec.parseOnly ((Attoparsec.signed Attoparsec.decimal) <* Attoparsec.endOfInput) byteString of
             Right value -> Right value
@@ -274,7 +274,7 @@ instance ParamReader Int where
     readParameterJSON _ = Left "ParamReader Int: Expected Int"
 
 instance ParamReader Integer where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         case Attoparsec.parseOnly ((Attoparsec.signed Attoparsec.decimal) <* Attoparsec.endOfInput) byteString of
             Right value -> Right value
@@ -287,7 +287,7 @@ instance ParamReader Integer where
     readParameterJSON _ = Left "ParamReader Integer: Expected Integer"
 
 instance ParamReader Double where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         case Attoparsec.parseOnly (Attoparsec.double <* Attoparsec.endOfInput) byteString of
             Right value -> Right value
@@ -300,7 +300,7 @@ instance ParamReader Double where
     readParameterJSON _ = Left "ParamReader Double: Expected Double"
 
 instance ParamReader Float where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         case Attoparsec.parseOnly (Attoparsec.double <* Attoparsec.endOfInput) byteString of
             Right value -> Right (Float.double2Float value)
@@ -313,7 +313,7 @@ instance ParamReader Float where
     readParameterJSON _ = Left "ParamReader Float: Expected Float"
 
 instance ParamReader ModelSupport.Point where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         case Attoparsec.parseOnly (do x <- Attoparsec.double; Attoparsec.char ','; y <- Attoparsec.double; Attoparsec.endOfInput; pure ModelSupport.Point { x, y }) byteString of
             Right value -> Right value
@@ -323,7 +323,7 @@ instance ParamReader ModelSupport.Point where
     readParameterJSON _ = Left "ParamReader Point: Expected Point"
 
 instance ParamReader Text where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString = pure (cs byteString)
 
     readParameterJSON (Aeson.String text) = Right text
@@ -335,7 +335,7 @@ instance ParamReader Text where
 --
 -- >>> let userIds :: [Int] = param "userIds"
 instance ParamReader value => ParamReader [value] where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         byteString
         |> Char8.split ','
@@ -360,7 +360,7 @@ instance ParamReader value => ParamReader [value] where
 -- Html form checkboxes usually use @on@ or @off@ for representation. These
 -- values are supported here.
 instance ParamReader Bool where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter on | on == cs (ModelSupport.inputValue True) = pure True
     readParameter true | toLower (cs true) == "true" = pure True
     readParameter _ = pure False
@@ -369,7 +369,7 @@ instance ParamReader Bool where
     readParameterJSON _ = Left "ParamReader Bool: Expected Bool"
 
 instance ParamReader UUID where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter byteString =
         case UUID.fromASCIIBytes byteString of
             Just uuid -> pure uuid
@@ -383,7 +383,7 @@ instance ParamReader UUID where
 
 -- | Accepts values such as @2020-11-08T12:03:35Z@ or @2020-11-08@
 instance ParamReader UTCTime where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter "" = Left "ParamReader UTCTime: Parameter missing"
     readParameter byteString =
         let
@@ -401,7 +401,7 @@ instance ParamReader UTCTime where
 
 -- | Accepts values such as @2020-11-08@
 instance ParamReader Day where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter "" = Left "ParamReader Day: Parameter missing"
     readParameter byteString =
         let
@@ -415,12 +415,12 @@ instance ParamReader Day where
     readParameterJSON _ = Left "ParamReader Day: Expected String"
 
 instance {-# OVERLAPS #-} (ParamReader (ModelSupport.PrimaryKey model')) => ParamReader (ModelSupport.Id' model') where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter uuid = ModelSupport.Id <$> readParameter uuid
     readParameterJSON value = ModelSupport.Id <$> readParameterJSON value
 
 instance ParamReader param => ParamReader (Maybe param) where
-    {-# INLINE readParameter #-}
+    {-# INLINABLE readParameter #-}
     readParameter param =
         case (readParameter param) :: Either ByteString param of
             Right value -> Right (Just value)
@@ -493,6 +493,7 @@ class FillParams (params :: [Symbol]) record where
 
 instance FillParams ('[]) record where
     fill !record = record
+    {-# INLINABLE fill #-}
 
 instance (FillParams rest record
     , KnownSymbol fieldName
@@ -509,6 +510,7 @@ instance (FillParams rest record
                     Left !error -> fill @rest (attachFailure (Proxy @fieldName) (cs error) record)
                     Right !(value :: fieldType) -> fill @rest (setField @fieldName value record)
             Nothing -> fill @rest record
+    {-# INLINABLE fill #-}
 
 ifValid :: (HasField "meta" model ModelSupport.MetaBag) => (Either model model -> IO r) -> model -> IO r
 ifValid branch model = branch ((if null annotations then Right else Left) model)

diff --git a/IHP/Controller/Render.hs b/IHP/Controller/Render.hs
@@ -24,15 +24,15 @@ import IHP.Controller.Layout
 
 renderPlain :: (?context :: ControllerContext) => LByteString -> IO ()
 renderPlain text = respondAndExit $ responseLBS status200 [(hContentType, "text/plain")] text
-{-# INLINE renderPlain #-}
+{-# INLINABLE renderPlain #-}
 
 respondHtml :: (?context :: ControllerContext) => Html -> IO ()
 respondHtml html = respondAndExit $ responseBuilder status200 [(hContentType, "text/html; charset=utf-8"), (hConnection, "keep-alive")] (Blaze.renderHtmlBuilder html)
-{-# INLINE respondHtml #-}
+{-# INLINABLE respondHtml #-}
 
 respondSvg :: (?context :: ControllerContext) => Html -> IO ()
 respondSvg html = respondAndExit $ responseBuilder status200 [(hContentType, "image/svg+xml"), (hConnection, "keep-alive")] (Blaze.renderHtmlBuilder html)
-{-# INLINE respondSvg #-}
+{-# INLINABLE respondSvg #-}
 
 renderHtml :: forall viewContext view controller. (ViewSupport.View view, ?theAction :: controller, ?context :: ControllerContext, ?modelContext :: ModelContext) => view -> IO Html
 renderHtml !view = do
@@ -49,23 +49,23 @@ renderHtml !view = do
 
     let boundHtml = let ?context = frozenContext in layout (ViewSupport.html ?view)
     pure boundHtml
-{-# INLINE renderHtml #-}
+{-# INLINABLE renderHtml #-}
 
 renderFile :: (?context :: ControllerContext, ?modelContext :: ModelContext) => String -> ByteString -> IO ()
 renderFile filePath contentType = respondAndExit $ responseFile status200 [(hContentType, contentType)] filePath Nothing
-{-# INLINE renderFile #-}
+{-# INLINABLE renderFile #-}
 
 renderJson :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => json -> IO ()
 renderJson json = respondAndExit $ responseLBS status200 [(hContentType, "application/json")] (Data.Aeson.encode json)
-{-# INLINE renderJson #-}
+{-# INLINABLE renderJson #-}
 
 renderJson' :: (?context :: ControllerContext) => ResponseHeaders -> Data.Aeson.ToJSON json => json -> IO ()
 renderJson' additionalHeaders json = respondAndExit $ responseLBS status200 ([(hContentType, "application/json")] <> additionalHeaders) (Data.Aeson.encode json)
-{-# INLINE renderJson' #-}
+{-# INLINABLE renderJson' #-}
 
 renderNotFound :: (?context :: ControllerContext) => IO ()
 renderNotFound = renderPlain "Not Found"
-{-# INLINE renderNotFound #-}
+{-# INLINABLE renderNotFound #-}
 
 data PolymorphicRender
     = PolymorphicRender
@@ -84,7 +84,7 @@ data PolymorphicRender
 --     }
 -- `
 -- This will render `Hello World` for normal browser requests and `true` when requested via an ajax request
-{-# INLINE renderPolymorphic #-}
+{-# INLINABLE renderPolymorphic #-}
 renderPolymorphic :: forall viewContext jsonType htmlType. (?context :: ControllerContext) => PolymorphicRender -> IO ()
 renderPolymorphic PolymorphicRender { html, json } = do
     let headers = Network.Wai.requestHeaders request
@@ -105,7 +105,7 @@ polymorphicRender :: PolymorphicRender
 polymorphicRender = PolymorphicRender Nothing Nothing
 
 
-{-# INLINE render #-}
+{-# INLINABLE render #-}
 render :: forall view controller. (ViewSupport.View view, ?theAction :: controller, ?context :: ControllerContext, ?modelContext :: ModelContext) => view -> IO ()
 render !view = do
     renderPolymorphic PolymorphicRender

diff --git a/IHP/ControllerSupport.hs b/IHP/ControllerSupport.hs
@@ -53,11 +53,13 @@ type Action' = IO ResponseReceived
 class (Show controller, Eq controller) => Controller controller where
     beforeAction :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller) => IO ()
     beforeAction = pure ()
+    {-# INLINABLE beforeAction #-}
     action :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller) => controller -> IO ()
 
 class InitControllerContext application where
     initContext :: (?modelContext :: ModelContext, ?requestContext :: RequestContext, ?applicationContext :: ApplicationContext, ?context :: ControllerContext) => IO ()
     initContext = pure ()
+    {-# INLINABLE initContext #-}
 
 {-# INLINE runAction #-}
 runAction :: forall controller. (Controller controller, ?context :: ControllerContext, ?modelContext :: ModelContext) => controller -> IO ResponseReceived
@@ -105,12 +107,12 @@ getRequestBody = Network.Wai.getRequestBodyChunk request
 -- | Returns the request path, e.g. @/Users@ or @/CreateUser@
 getRequestPath :: (?context :: ControllerContext) => ByteString
 getRequestPath = Network.Wai.rawPathInfo request
-{-# INLINE getRequestPath #-}
+{-# INLINABLE getRequestPath #-}
 
 -- | Returns the request path and the query params, e.g. @/ShowUser?userId=9bd6b37b-2e53-40a4-bb7b-fdba67d6af42@
 getRequestPathAndQuery :: (?context :: ControllerContext) => ByteString
 getRequestPathAndQuery = Network.Wai.rawPathInfo request <> Network.Wai.rawQueryString request
-{-# INLINE getRequestPathAndQuery #-}
+{-# INLINABLE getRequestPathAndQuery #-}
 
 -- | Returns a header value for a given header name. Returns Nothing if not found
 --
@@ -124,7 +126,7 @@ getRequestPathAndQuery = Network.Wai.rawPathInfo request <> Network.Wai.rawQuery
 --
 getHeader :: (?context :: ControllerContext) => ByteString -> Maybe ByteString
 getHeader name = lookup (Data.CaseInsensitive.mk name) (Network.Wai.requestHeaders request)
-{-# INLINE getHeader #-}
+{-# INLINABLE getHeader #-}
 
 -- | Returns the current HTTP request.
 --