Merge FromParam with ToParam into Param

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

hikaru.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c3d7457dca96378df357bb52bd4eb8bf006764d262483124af6a580c32a228b7
+-- hash: 789872e5159353725050ec2764d9951be0fbf0c39bb684307f281650bb6fd9a8
 
 name:           hikaru
 version:        0.1.0.0
@@ -47,7 +47,7 @@ library
       Paths_hikaru
   hs-source-dirs:
       lib
-  default-extensions: BlockArguments DefaultSignatures FlexibleInstances GeneralizedNewtypeDeriving GADTs LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving
+  default-extensions: BlockArguments DataKinds DefaultSignatures FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
   ghc-options: -Wall -Wcompat
   build-depends:
       aeson >=1.4 && <1.5

lib/Hikaru/Action.hs

@@ -99,6 +99,7 @@ where
 
   import qualified Data.ByteString.Lazy as LBS
   import qualified Data.Text.Lazy as LT
+  import qualified Network.Wai.Parse as Parse
 
   import Control.Monad.Trans
   import Control.Monad.Trans.Resource
@@ -112,7 +113,6 @@ where
   import Network.HTTP.Types.Method
   import Network.HTTP.Types.Status
   import Network.Wai
-  import Network.Wai.Parse
   import Web.Cookie
   import Hikaru.Media
   import Hikaru.Types
@@ -364,14 +364,14 @@ where
   --
   getParams :: (MonadAction m) => m [(Text, Text)]
   getParams = map convert <$> queryString <$> getRequest
-    where convert (n, v) = (cs n, fromMaybe "" $ cs <$> v)
+    where convert (n, v) = (cs n, maybe "" cs v)
 
 
   -- |
   -- Obtain a specific request query string parameter and parse it
   -- on the fly to the target type. Parsing failure maps to 'Nothing'.
   --
-  getParamMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a)
+  getParamMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
   getParamMaybe n = do
     value <- lookup n <$> getParams
     return $ fromParam =<< value
@@ -381,7 +381,7 @@ where
   -- Similar to 'getParamMaybe', but return either the parsed parameter
   -- or the specified default value.
   --
-  getParamDefault :: (MonadAction m, FromParam a) => Text -> a -> m a
+  getParamDefault :: (MonadAction m, Param a) => Text -> a -> m a
   getParamDefault n v = fromMaybe v <$> getParamMaybe n
 
 
@@ -389,7 +389,7 @@ where
   -- Obtain a group of request query string parameters with the same name
   -- and parse them on the fly to the target type.
   --
-  getParamList :: (MonadAction m, FromParam a) => Text -> m [a]
+  getParamList :: (MonadAction m, Param a) => Text -> m [a]
   getParamList n = mapMaybe (fromParam . snd)
                    <$> filter ((n ==) . fst)
                    <$> getParams
@@ -411,7 +411,7 @@ where
   -- Obtain a specific cookie and parse it on the fly to the target type.
   -- Parsing failure maps to 'Nothing'.
   --
-  getCookieMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a)
+  getCookieMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
   getCookieMaybe n = do
     value <- lookup n <$> getCookies
     return $ fromParam =<< value
@@ -421,7 +421,7 @@ where
   -- Similar to 'getCookieMaybe', but return either the parsed cookie
   -- or the specified default value.
   --
-  getCookieDefault :: (MonadAction m, FromParam a) => Text -> a -> m a
+  getCookieDefault :: (MonadAction m, Param a) => Text -> a -> m a
   getCookieDefault n v = fromMaybe v <$> getCookieMaybe n
 
 
@@ -623,7 +623,7 @@ where
   -- Obtain a specific form field and parse it on the fly to the target type.
   -- Parsing failure maps to 'Nothing'.
   --
-  getFieldMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a)
+  getFieldMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
   getFieldMaybe n = do
     value <- lookup n <$> getFields
     return $ fromParam =<< value
@@ -633,7 +633,7 @@ where
   -- Similar to 'getFieldMaybe', but return either the parsed field
   -- or the specified default value.
   --
-  getFieldDefault :: (MonadAction m, FromParam a) => Text -> a -> m a
+  getFieldDefault :: (MonadAction m, Param a) => Text -> a -> m a
   getFieldDefault n v = fromMaybe v <$> getFieldMaybe n
 
 
@@ -641,7 +641,7 @@ where
   -- Obtain a group of form fields with the same name and parse them on the
   -- fly to the target type.
   --
-  getFieldList :: (MonadAction m, FromParam a) => Text -> m [a]
+  getFieldList :: (MonadAction m, Param a) => Text -> m [a]
   getFieldList n = mapMaybe (fromParam . snd)
                    <$> filter ((n ==) . fst)
                    <$> getFields
@@ -691,7 +691,7 @@ where
 
       -- Body has not been parsed yet. This is very good.
       BodyUnparsed -> do
-        bodyType <- getRequestBodyType <$> getRequest
+        bodyType <- Parse.getRequestBodyType <$> getRequest
         getChunk <- getBodyChunkIO
 
         case bodyType of
@@ -703,7 +703,7 @@ where
 
             -- Parse the form data.
             form' <- liftIO do
-              sinkRequestBody (tempFileBackEnd rtis) bt getChunk
+              Parse.sinkRequestBody (Parse.tempFileBackEnd rtis) bt getChunk
 
             -- Perform string conversions and simplify uploaded file types.
             let form = adaptForm form'
@@ -720,12 +720,12 @@ where
 
   -- |
   -- Convert form names and fields from 'ByteString' to 'Text' and
-  -- extract just the uploaded file names from the 'FileInfo' structures.
+  -- extract just the uploaded file names from the 'Parse.FileInfo' structures.
   --
-  adaptForm :: ([Param], [(ByteString, FileInfo FilePath)]) -> FormData
+  adaptForm :: ([Parse.Param], [(ByteString, Parse.FileInfo FilePath)]) -> FormData
   adaptForm (ps, fs) = (map cs2 ps, map convFile fs)
     where
-      convFile (n, FileInfo{fileContent}) = (cs n, fileContent)
+      convFile (n, Parse.FileInfo{fileContent}) = (cs n, fileContent)
 
 
   -- |

lib/Hikaru/Form.hs

@@ -170,7 +170,7 @@ where
     {-# INLINE fmap #-}
 
   instance (Monad m) => Applicative (Form l m) where
-    pure x = Form $ return $ Just x
+    pure x = Form $ pure $ Just x
     {-# INLINE pure #-}
 
     Form{unForm = unFormL} <*> Form{unForm = unFormR} = Form do
@@ -286,7 +286,7 @@ where
   -- |
   -- TODO
   --
-  hiddenField' :: (Monad m, ToParam a, FromParam a)
+  hiddenField' :: (Monad m, Param a)
                => Text -> FieldT l a m b -> Form l m a
   hiddenField' name field = hiddenField name Nothing field
 
@@ -294,7 +294,7 @@ where
   -- |
   -- TODO
   --
-  hiddenField :: (Monad m, ToParam a, FromParam a)
+  hiddenField :: (Monad m, Param a)
               => Text -> Maybe a -> FieldT l a m b -> Form l m a
   hiddenField name orig field = Form do
     name' <- makeName name
@@ -316,7 +316,7 @@ where
   -- |
   -- TODO
   --
-  inputField' :: (Monad m, ToParam a, FromParam a)
+  inputField' :: (Monad m, Param a)
               => Text -> l -> FieldT l a m b -> Form l m a
   inputField' name label field = inputField name label Nothing field
 
@@ -324,7 +324,7 @@ where
   -- |
   -- TODO
   --
-  inputField :: (Monad m, ToParam a, FromParam a)
+  inputField :: (Monad m, Param a)
              => Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
   inputField name label orig field = Form do
     name' <- makeName name
@@ -347,7 +347,7 @@ where
   -- |
   -- TODO
   --
-  textArea' :: (Monad m, ToParam a, FromParam a)
+  textArea' :: (Monad m, Param a)
             => Text -> l -> FieldT l a m b -> Form l m a
   textArea' name label field = textArea name label Nothing field
 
@@ -355,7 +355,7 @@ where
   -- |
   -- TODO
   --
-  textArea :: (Monad m, ToParam a, FromParam a)
+  textArea :: (Monad m, Param a)
             => Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
   textArea name label orig field = Form do
     name' <- makeName name
@@ -378,7 +378,7 @@ where
   -- |
   -- TODO
   --
-  selectField' :: (Monad m, ToParam a, FromParam a, Eq a)
+  selectField' :: (Monad m, Param a, Eq a)
                => Text -> l -> (a -> l) -> [a]
                -> FieldT l a m b -> Form l m a
   selectField' name label optlabel options field
@@ -388,7 +388,7 @@ where
   -- |
   -- TODO
   --
-  selectField :: (Monad m, ToParam a, FromParam a, Eq a)
+  selectField :: (Monad m, Param a, Eq a)
               => Text -> l -> (a -> l) -> [a] -> Maybe a
               -> FieldT l a m b -> Form l m a
   selectField name label optlabel options orig field = Form do
@@ -414,7 +414,7 @@ where
   -- |
   -- TODO
   --
-  selectFieldEnum' :: (Monad m, ToParam a, FromParam a, Eq a, Bounded a, Enum a)
+  selectFieldEnum' :: (Monad m, Param a, Eq a, Bounded a, Enum a)
                    => Text -> l -> (a -> l) -> FieldT l a m b -> Form l m a
   selectFieldEnum' name label optlabel field
     = selectFieldEnum name label optlabel Nothing field
@@ -425,7 +425,7 @@ where
   --
   -- TODO: Example
   --
-  selectFieldEnum :: (Monad m, ToParam a, FromParam a, Eq a, Bounded a, Enum a)
+  selectFieldEnum :: (Monad m, Param a, Eq a, Bounded a, Enum a)
                   => Text -> l -> (a -> l) -> Maybe a
                   -> FieldT l a m b -> Form l m a
   selectFieldEnum name label optlabel orig field
@@ -435,7 +435,7 @@ where
   -- |
   -- TODO
   --
-  multiSelectField' :: (Monad m, ToParam a, FromParam a, Eq a)
+  multiSelectField' :: (Monad m, Param a, Eq a)
                     => Text -> l -> (a -> l) -> [a]
                     -> FieldT l [a] m b -> Form l m [a]
   multiSelectField' name label optlabel options field
@@ -445,7 +445,7 @@ where
   -- |
   -- TODO
   --
-  multiSelectField :: (Monad m, ToParam a, FromParam a, Eq a)
+  multiSelectField :: (Monad m, Param a, Eq a)
                    => Text -> l -> (a -> l) -> [a] -> Maybe [a]
                    -> FieldT l [a] m b -> Form l m [a]
   multiSelectField name label optlabel options orig field = Form do
@@ -566,7 +566,7 @@ where
   isErrorNote _else                  = False
 
 
-  formParamMaybe :: (Monad m, FromParam a) => Text -> FormT l m (Maybe a)
+  formParamMaybe :: (Monad m, Param a) => Text -> FormT l m (Maybe a)
   formParamMaybe name = do
     Env{envParams} <- ask
     return $ fromParam =<< lookup name envParams
@@ -578,7 +578,7 @@ where
     return $ lookup name envFiles
 
 
-  formParams :: (Monad m, FromParam a) => Text -> FormT l m [a]
+  formParams :: (Monad m, Param a) => Text -> FormT l m [a]
   formParams name = do
     Env{envParams} <- ask
     let match = (name ==) . fst

lib/Hikaru/Route.hs

@@ -234,7 +234,7 @@ where
   --
   -- Fails with 'NotFound' if the segment is missing or unparseable.
   --
-  arg :: (FromParam a) => Route a
+  arg :: (Param a) => Route a
   arg = argWith fromParam
 
 

lib/Hikaru/Types.hs

@@ -11,9 +11,9 @@ This module provides types common for multiple other modules.
 -}
 
 module Hikaru.Types
-  ( FromParam(..)
-  , ToParam(..)
+  ( Param(..)
   , RequestError(..)
+  , Severity(..)
   , defaultHandler
   )
 where
@@ -37,192 +37,176 @@ where
   -- parameter into some kind of value. One does not usually pass around
   -- more complex arguments than these, so forgive the limited menu.
   --
-  class FromParam a where
+  class Param a where
     fromParam :: Text -> Maybe a
+    toParam   :: a -> Text
 
-  instance FromParam Int where
-    fromParam = readMaybe . unpack
+  instance (Param a) => Param (Maybe a) where
+    fromParam = Just . fromParam
     {-# INLINE fromParam #-}
 
-  instance FromParam Int8 where
-    fromParam = readMaybe . unpack
-
-    {-# INLINE fromParam #-}
-  instance FromParam Int16 where
-    fromParam = readMaybe . unpack
-    {-# INLINE fromParam #-}
+    toParam = maybe "" toParam
+    {-# INLINE toParam #-}
 
-  instance FromParam Int32 where
+  instance Param Int where
     fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam Int64 where
-    fromParam = readMaybe . unpack
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Word where
+  instance Param Int8 where
     fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam Word8 where
-    fromParam = readMaybe . unpack
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Word16 where
+  instance Param Int16 where
     fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam Word32 where
-    fromParam = readMaybe . unpack
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Word64 where
+  instance Param Int32 where
     fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam Integer where
-    fromParam = readMaybe . unpack
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Natural where
+  instance Param Int64 where
     fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam Float where
-    fromParam = readMaybe . unpack
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Double where
+  instance Param Word where
     fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam () where
-    fromParam _ = Just ()
-    {-# INLINE fromParam #-}
-
-  instance FromParam Bool where
-    fromParam "true"  = Just True
-    fromParam "True"  = Just True
-    fromParam "false" = Just False
-    fromParam "False" = Just False
-    fromParam _else   = Nothing
-    {-# INLINE fromParam #-}
-
-  instance FromParam Char where
-    fromParam inp = case (unpack inp) of
-                      [x]   -> Just x
-                      _else -> Nothing
-    {-# INLINE fromParam #-}
-
-  instance FromParam Text where
-    fromParam = Just . id
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Data.Text.Lazy.Text where
-    fromParam = Just . Data.Text.Lazy.fromStrict
+  instance Param Word8 where
+    fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-  instance FromParam Data.ByteString.ByteString where
-    fromParam = Just . Data.Text.Encoding.encodeUtf8
-    {-# INLINE fromParam #-}
+    toParam = pack . show
+    {-# INLINE toParam #-}
 
-  instance FromParam Data.ByteString.Lazy.ByteString where
-    fromParam = Just . Data.ByteString.Lazy.fromStrict
-                     . Data.Text.Encoding.encodeUtf8
+  instance Param Word16 where
+    fromParam = readMaybe . unpack
     {-# INLINE fromParam #-}
 
-
-  -- |
-  -- Values that can be represented as a piece of 'Text' to be used in a
-  -- route segment or a query string. One does not usually pass around
-  -- more complex arguments than these, so forgive the limited menu.
-  --
-  class ToParam a where
-    toParam :: a -> Text
-
-  instance ToParam Int where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Int8 where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param Word32 where
+    fromParam = readMaybe . unpack
+    {-# INLINE fromParam #-}
 
-  instance ToParam Int16 where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Int32 where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param Word64 where
+    fromParam = readMaybe . unpack
+    {-# INLINE fromParam #-}
 
-  instance ToParam Int64 where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Word where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param Integer where
+    fromParam = readMaybe . unpack
+    {-# INLINE fromParam #-}
 
-  instance ToParam Word8 where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Word16 where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param Natural where
+    fromParam = readMaybe . unpack
+    {-# INLINE fromParam #-}
 
-  instance ToParam Word32 where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Word64 where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param Float where
+    fromParam = readMaybe . unpack
+    {-# INLINE fromParam #-}
 
-  instance ToParam Integer where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Natural where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param Double where
+    fromParam = readMaybe . unpack
+    {-# INLINE fromParam #-}
 
-  instance ToParam Float where
     toParam = pack . show
     {-# INLINE toParam #-}
 
-  instance ToParam Double where
-    toParam = pack . show
-    {-# INLINE toParam #-}
+  instance Param () where
+    fromParam _ = Just ()
+    {-# INLINE fromParam #-}
 
-  instance ToParam () where
     toParam _ = ""
     {-# INLINE toParam #-}
 
-  instance ToParam Bool where
+  instance Param Bool where
+    fromParam "true"  = Just True
+    fromParam "True"  = Just True
+    fromParam "on"    = Just True
+    fromParam "On"    = Just True
+    fromParam "1"     = Just True
+    fromParam "false" = Just False
+    fromParam "False" = Just False
+    fromParam "off"   = Just False
+    fromParam "Off"   = Just False
+    fromParam "0"     = Just False
+    fromParam _else   = Nothing
+    {-# INLINE fromParam #-}
+
     toParam True  = "true"
     toParam False = "false"
     {-# INLINE toParam #-}
 
-  instance ToParam Char where
+  instance Param Char where
+    fromParam inp = case (unpack inp) of
+                      [x]   -> Just x
+                      _else -> Nothing
+    {-# INLINE fromParam #-}
+
     toParam char = pack [char]
     {-# INLINE toParam #-}
 
-  instance ToParam Text where
+  instance Param Text where
+    fromParam = Just . id
+    {-# INLINE fromParam #-}
+
     toParam = id
     {-# INLINE toParam #-}
 
-  instance ToParam Data.Text.Lazy.Text where
+  instance Param Data.Text.Lazy.Text where
+    fromParam = Just . Data.Text.Lazy.fromStrict
+    {-# INLINE fromParam #-}
+
     toParam = Data.Text.Lazy.toStrict
     {-# INLINE toParam #-}
 
-  instance ToParam Data.ByteString.ByteString where
+  instance Param Data.ByteString.ByteString where
+    fromParam = Just . Data.Text.Encoding.encodeUtf8
+    {-# INLINE fromParam #-}
+
     toParam = Data.Text.Encoding.decodeUtf8With
                 Data.Text.Encoding.Error.lenientDecode
     {-# INLINE toParam #-}
 
-  instance ToParam Data.ByteString.Lazy.ByteString where
+  instance Param Data.ByteString.Lazy.ByteString where
+    fromParam = Just . Data.ByteString.Lazy.fromStrict
+                     . Data.Text.Encoding.encodeUtf8
+    {-# INLINE fromParam #-}
+
     toParam = Data.Text.Encoding.decodeUtf8With
                 Data.Text.Encoding.Error.lenientDecode
             . Data.ByteString.Lazy.toStrict
@@ -327,4 +311,26 @@ where
                          . cs . (<> "\n" <> msg)
 
 
+  -- |
+  -- Information severity to be used for messages.
+  --
+  data Severity
+    = Success
+    | Warning
+    | Danger
+    deriving (Eq, Ord, Enum, Show)
+
+  -- |
+  -- Concatenation yields the higher severity.
+  --
+  instance Semigroup Severity where
+    (<>) = max
+
+  -- |
+  -- 'Success' is the neutral element.
+  --
+  instance Monoid Severity where
+    mempty = Success
+
+
 -- vim:set ft=haskell sw=2 ts=2 et:

package.yaml

@@ -24,10 +24,12 @@ extra-source-files: README.md
 ghc-options: -Wall -Wcompat
 default-extensions:
   - BlockArguments
+  - DataKinds
   - DefaultSignatures
   - FlexibleInstances
-  - GeneralizedNewtypeDeriving
   - GADTs
+  - GeneralizedNewtypeDeriving
+  - KindSignatures
   - LambdaCase
   - MultiParamTypeClasses
   - NamedFieldPuns
@@ -37,6 +39,7 @@ default-extensions:
   - RecordWildCards
   - ScopedTypeVariables
   - StandaloneDeriving
+  - UndecidableInstances
 
 dependencies:
   - aeson              >= 1.4  && <1.5