diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ -## 0.1.0.0 - -* First version. Released on an unsuspecting world. +## 0.2.0.0 + +* Removed 'Flag', 'named', 'Apply', 'apply'. +* Changed notation: 'Named' is now '(:!)' in types, 'Arg' in patterns. +* Added 'arg', 'argF'. +* Support for optional parameters: see 'argDef', 'defaults', '(:?)'. +* 'with #param value' is now 'with (#param value)' to allow 'with defaults'. +* Internals are now exposed from "Named.Internal". + +## 0.1.0.0 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2018, Vladislav Zavialov - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Vladislav Zavialov nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2018, Vladislav Zavialov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Vladislav Zavialov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/named.cabal b/named.cabal --- a/named.cabal +++ b/named.cabal @@ -1,57 +1,61 @@ -name: named -version: 0.1.0.0 -synopsis: Named parameters (keyword arguments) for Haskell -description: - `named` is a lightweight library for named function parameters (keyword - arguments) based on overloaded labels. Keyword arguments have several - advantages over positional arguments: - . - * they can be supplied in arbitrary order - * their names serve as documentation at call site - * it is impossible to accidentally mix them up - . - Unlike @newtype@ wrappers, keyword arguments don't pollute the global - namespace, don't require top-level definitions, and don't need to be - exported. - . - This implementation of named parameters is typesafe, provides good type - inference, descriptive type errors, and has no runtime overhead. - . - Example usage: - . - > import Named - > - > createSymLink :: FilePath `Named` "from" -> FilePath `Named` "to" -> IO () - > createSymLink (Named from) (Named to) = ... - > - > main = createSymLink ! #from "/path/to/source" - > ! #to "/target/path" - - -license: BSD3 -license-file: LICENSE -author: Vladislav Zavialov -maintainer: Vladislav Zavialov -category: Control -build-type: Simple -extra-source-files: ChangeLog.md -tested-with: GHC ==8.0.2, GHC ==8.2.2, GHC ==8.4.1 -cabal-version: >=1.10 - -library - exposed-modules: Named - build-depends: base >=4.9 && <4.12 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - -fno-warn-unticked-promoted-constructors - -test-suite regression - type: exitcode-stdio-1.0 - main-is: Test.hs - build-depends: base >=4.9 && <4.12, - named - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall +name: named +version: 0.2.0.0 +synopsis: Named parameters (keyword arguments) for Haskell +description: + `named` is a lightweight library for named function parameters (keyword + arguments) based on overloaded labels. Keyword arguments have several + advantages over positional arguments: + . + * they can be supplied in arbitrary order + * their names serve as documentation at call site + * it is impossible to accidentally mix them up + . + Unlike @newtype@ wrappers, keyword arguments don't pollute the global + namespace, don't require top-level definitions, and don't need to be + exported. + . + This implementation of named parameters is typesafe, provides good type + inference, descriptive type errors, and has no runtime overhead. + . + Example usage: + . + > import Named + > + > createSymLink :: "from" :! FilePath -> "to" :! FilePath -> IO () + > createSymLink (Arg from) (Arg to) = ... + > + > main = createSymLink ! #from "/path/to/source" + > ! #to "/target/path" + + +license: BSD3 +license-file: LICENSE +author: Vladislav Zavialov +maintainer: Vladislav Zavialov +category: Control +build-type: Simple +extra-source-files: ChangeLog.md +tested-with: GHC ==8.0.2, GHC ==8.2.2, GHC ==8.4.1 +cabal-version: >=1.10 + +source-repository head + type: git + location: git@github.com:int-index/named.git + +library + exposed-modules: Named, Named.Internal + build-depends: base >=4.9 && <4.12 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -fno-warn-unticked-promoted-constructors + +test-suite regression + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base >=4.9 && <4.12, + named + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-missing-signatures diff --git a/src/Named.hs b/src/Named.hs --- a/src/Named.hs +++ b/src/Named.hs @@ -1,255 +1,176 @@ -{-# LANGUAGE KindSignatures, DataKinds, FlexibleInstances, FlexibleContexts, - FunctionalDependencies, TypeFamilies, TypeOperators, - PatternSynonyms, UndecidableInstances, ConstraintKinds, - TypeApplications, ScopedTypeVariables, CPP #-} - -{- | - -Named parameters, also known as keyword arguments, have several advantages -over positional arguments: - -* convenience: they can be supplied in arbitrary order -* readability: their names serve as documentation at call site -* safety: it is impossible to accidentally mix them up - -Consider a function to replace a substring with another string: - -@ -Text.replace path "$HOME" "\/home\/username\/" -@ - -We want to replace references to the @$HOME@ environment variable with a -concrete directory. There is but one problem – we have supplied the text -arguments in the wrong order. - -Compare that to a newtype-based solution: - -@ -Text.replace - (Needle "$HOME") - (Replacement "\/home\/username\/") - (Haystack path) -@ - -Now that the function requires each argument to be wrapped in a newtype, we -cannot mix them up – the compiler will report an error, and newtype constructors -serve as documentation. - -The problem with newtypes is that it is bothersome to create them for each -parameter, they pollute the global namespace, and we still cannot supply wrapped -arguments in arbitrary order. - -With keyword arguments, none of that is a problem: - -@ -Text.replace '!' #haystack path - '!' #needle "$HOME" - '!' #replacement "\/home\/username\/" -@ - -Functions must declare their parameter names in the type signature: - -@ -replace :: - Text \``Named`\` "needle" -> - Text \``Named`\` "replacement" -> - Text \``Named`\` "haystack" -> - Text -replace (Named needle) (Named replacement) (Named haystack) = - ... -@ - -Keyword arguments have seamless interoperability with positional arguments when -the function takes them last. Consider this function: - -@ -foo :: A -> B -> C \``Named`\` "x" -> IO () -@ - -There are several ways to invoke it: - -@ -(foo a b) '!' #x c -- parentheses for clarity -(foo a '!' #x c) b -- parentheses required -(foo '!' #x c) a b -- parentheses required -@ - -We can also supply keyword arguments using the 'with' combinator instead of -the '!' operator: - -@ -('with' #x c foo) a b -- parentheses for clarity -'with' #x c (foo a b) -- has the same effect -@ - -Both '!' and 'with' work in a similar manner: they traverse the spine of -the function and supply the first keyword argument with a matching name. - -For example: - -@ -bar :: A \``Named`\` "x" -> B \``Named`\` "y" -> IO () -bar '!' #y b :: A \``Named`\` "x" -> IO () -'with' #y b bar :: A \``Named`\` "x" -> IO () -@ - --} -module Named - ( - -- * Core interface - Named(..), - (!), - Name(..), - with, - - -- * Specialized synonyms - Flag, - pattern Flag, - - -- * Internal - Apply, - apply, - named - ) where - -import Prelude (Bool, id) -import Data.Kind (Type) -import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..)) -import GHC.OverloadedLabels (IsLabel(..)) - -{- | - -Assign a name to a value of type @a@. This is a simple wrapper intended -for use with @-XOverloadedLabels@: - -@ -#verbose True :: Named Bool "verbose" -@ - --} -newtype Named a (name :: Symbol) = Named { unnamed :: a } - -instance (name ~ name', a ~ a') => IsLabel name (a -> Named a' name') where -#if MIN_VERSION_base(4,10,0) - fromLabel = Named -#else - fromLabel _ = Named -#endif - {-# INLINE fromLabel #-} - --- | Snake oil to cure boolean blindness. -type Flag = Named Bool - --- | Match on a flag, a version of 'Named' specialized to 'Bool'. -pattern Flag :: Bool -> Flag name -pattern Flag a = Named a - -#if MIN_VERSION_base(4,10,0) -{-# COMPLETE Flag #-} -#endif - -{- | Supply a keyword argument to a function: - -@ -function ! #param_name value -@ --} - -(!) :: Apply name a fn fn' => fn -> Named a name -> fn' -(!) = apply -{-# INLINE (!) #-} - -infixl 9 ! - -{- | - -A proxy for a name, intended for use with @-XOverloadedLabels@: - -@ -#verbose :: Name "verbose" -@ - --} -data Name (name :: Symbol) = Name - -instance name ~ name' => IsLabel name' (Name name) where -#if MIN_VERSION_base(4,10,0) - fromLabel = Name -#else - fromLabel _ = Name -#endif - {-# INLINE fromLabel #-} - -{- | Supply a keyword argument to a function: - -@ -with #param_name value function -@ --} -with :: Apply name a fn fn' => Name name -> a -> fn -> fn' -with name a fn = fn ! named name a -{-# INLINE with #-} - --- | Annotate a value with a name. -named :: Name name -> a -> Named a name -named _ = Named -{-# INLINE named #-} - --------------------------------------------------------------------------------- --- Do not read further to avoid emotional trauma. --------------------------------------------------------------------------------- - -data Decision = Done | Skip Decision - -type family Decide (name :: Symbol) (fn :: Type) :: Decision where - Decide name (Named a name -> r) = Done - Decide name (x -> r) = Skip (Decide name r) - Decide name t = - TypeError (Text "Named parameter '" :<>: Text name :<>: - Text "' was supplied, but not expected") - -class - ( decision ~ Decide name fn - ) => Apply' decision name a fn fn' | name fn -> fn' - where - -- | Apply a function to a keyword argument. - apply :: fn -> Named a name -> fn' - -instance - ( fn ~ (Named a name -> r), - fn' ~ r, - Decide name fn ~ Done - ) => Apply' Done name a fn fn' - where - apply = id - {-# INLINE apply #-} - -instance - ( Apply' decision name a r r', - Decide name fn ~ Skip decision, - fn ~ (x -> r), - fn' ~ (x -> r') - ) => Apply' (Skip decision) name a fn fn' - where - apply fn a = \x -> apply (fn x) a - {-# INLINE apply #-} - -{- | - -Supply a parameter of type @a@ named @name@ to a function @fn@, resulting in -@fn'@. - -For example: - -@ -Apply "x" Char - (Named Bool "b" -> Named Char "x" -> r) - (Named Bool "b" -> r) -@ - -In case the parameter cannot be supplied, this constraint will become a type -error. - --} -type Apply (name :: Symbol) (a :: Type) (fn :: Type) (fn' :: Type) = - Apply' (Decide name fn) name a fn fn' +{-# LANGUAGE PatternSynonyms, ExplicitNamespaces #-} + +{- | + +Named parameters, also known as keyword arguments, have several advantages +over positional arguments: + +* convenience: they can be supplied in arbitrary order +* readability: their names serve as documentation at call site +* safety: it is impossible to accidentally mix them up + +Consider a function to replace a substring with another string: + +@ +Text.replace path "$HOME" "\/home\/username\/" +@ + +We want to replace references to the @$HOME@ environment variable with a +concrete directory. There is but one problem – we have supplied the text +arguments in the wrong order. + +Compare that to a newtype-based solution: + +@ +Text.replace + (Needle "$HOME") + (Replacement "\/home\/username\/") + (Haystack path) +@ + +Now that the function requires each argument to be wrapped in a newtype, we +cannot mix them up – the compiler will report an error, and newtype constructors +serve as documentation. + +The problem with newtypes is that it is bothersome to create them for each +parameter, they pollute the global namespace, and we still cannot supply wrapped +arguments in arbitrary order. + +With keyword arguments, none of that is a problem: + +@ +Text.replace '!' \#haystack path + '!' \#needle "$HOME" + '!' \#replacement "\/home\/username\/" +@ + +Functions can declare their parameter names in pattern bindings: + +@ +replace ('arg' \#needle -> n) ('arg' \#replacement -> r) ('arg' \#haystack -> h) = + ... +@ + +Types are inferred, but it is possible to specify them. When the parameter +names are specified in the type signature, they can be omitted from the +pattern bindings: + +@ +replace :: + "needle" ':!' Text -> + "replacement" ':!' Text -> + "haystack" ':!' Text -> + Text +replace ('Arg' n) ('Arg' r) ('Arg' h) = + ... +@ + +Keyword arguments have seamless interoperability with positional arguments when +the function takes them last. Consider this function: + +@ +foo :: A -> B -> "x" :! C -> IO () +@ + +There are several ways to invoke it: + +@ +(foo a b) '!' \#x c -- parentheses for clarity +(foo a '!' \#x c) b -- parentheses required +(foo '!' \#x c) a b -- parentheses required +@ + +We can also supply keyword arguments using the 'with' combinator instead of +the '!' operator: + +@ +('with' (\#x c) foo) a b -- parentheses for clarity +'with' (\#x c) (foo a b) -- has the same effect +@ + +Both '!' and 'with' work in a similar manner: they traverse the spine of +the function and supply the first keyword argument with a matching name. + +For example: + +@ +bar :: "x" :! A -> "y" :! B -> IO () +bar '!' \#y b :: "x" :! A -> IO () +'with' (\#y b) bar :: "x" :! A -> IO () +@ + +There is also support for optional parameters. A function can specify default +values for some of its arguments: + +@ +log :: + "message" ':!' Text -> + "severity" ':?' Severity -> + "handle" ':?' Handle -> + IO () +log ('arg' #message -> msg) + ('argDef' #severity Error -> sev) + ('argDef' #handle stderr -> hndl) + = ... +@ + +Optional parameters are denoted with (':?') instead of (':!'). Instead of 'arg' +to match on them, we must use either 'argDef' to provide a default value or +'argF' to get a value wrapped in 'Maybe' ('Just' when the parameter was +specified, 'Nothing' when omitted). + +At call site, optional parameters are passed using the same ('!') operator: + +@ +log '!' #message "All your base are belong to us" + '!' #severity Info + '!' #handle stdout +@ + +To use the default values for all unspecified optional parameters, we can pass +'defaults' to the function: + +@ +log '!' #message "Could not match type 'Int' with type 'Bool'" + '!' 'defaults' +@ + +@ +log '!' #message "The password must contain a letter, \\ + \\a digit, and a plot twist" + '!' #severity Warning + '!' 'defaults' +@ + +We can also pass 'defaults' using 'with', which has the same effect as the ('!') +operator: + +@ +'with' 'defaults' $ + log '!' #message "Connection interrupted" + '!' #handle logfile +@ + +-} +module Named + ( + -- * Calling functions + (!), + WithParam(..), + defaults, + + -- * Types + type (:!), + type (:?), + NamedF, + + -- * Patterns + Name(..), + arg, + argDef, + argF, + pattern Arg, + pattern ArgF, + ) where + +import Named.Internal diff --git a/src/Named/Internal.hs b/src/Named/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Named/Internal.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE KindSignatures, DataKinds, FlexibleInstances, FlexibleContexts, + FunctionalDependencies, TypeFamilies, TypeOperators, + PatternSynonyms, UndecidableInstances, ConstraintKinds, + TypeApplications, ScopedTypeVariables, CPP, + AllowAmbiguousTypes #-} + +module Named.Internal where + +import Prelude (id, Maybe(..)) +import Data.Maybe (fromMaybe) +import Data.Functor.Identity (Identity(..)) +import Data.Kind (Type) +import GHC.TypeLits (Symbol, TypeError, ErrorMessage(..)) +import GHC.OverloadedLabels (IsLabel(..)) + +{- | + +Assign a name to a value of type @a@ wrapped in @f@. + +@ +#verbose True :: NamedF Identity Bool "verbose" +@ + +-} +newtype NamedF f (a :: Type) (name :: Symbol) = + ArgF (f a) -- ^ Match on an F-argument without specifying its name. + -- See also: 'argF'. + +-- | Match on an argument without specifying its name. See also: 'arg'. +pattern Arg :: a -> name :! a +pattern Arg a = ArgF (Identity a) + +#if MIN_VERSION_base(4,10,0) +{-# COMPLETE Arg #-} +#endif + +-- | Infix notation for the type of a named parameter. +type name :! a = NamedF Identity a name + +-- | Infix notation for the type of an optional named parameter. +type name :? a = NamedF Maybe a name + +class InjValue f where + injValue :: a -> f a + +instance InjValue Identity where + injValue = Identity + +instance InjValue Maybe where + injValue = Just + +instance (name ~ name', a ~ a', InjValue f) => IsLabel name (a -> NamedF f a' name') where +#if MIN_VERSION_base(4,10,0) + fromLabel a = ArgF (injValue a) +#else + fromLabel _ a = ArgF (injValue a) +#endif + {-# INLINE fromLabel #-} + +newtype Param p = Param p + +instance (p ~ NamedF f a name, InjValue f) => IsLabel name (a -> Param p) where +#if MIN_VERSION_base(4,10,0) + fromLabel a = Param (fromLabel @name a) +#else + fromLabel pName a = Param (fromLabel pName a) +#endif + {-# INLINE fromLabel #-} + +{- | Supply a parameter to a function: + +@ +function '!' \#param_name value +@ + +@ +function '!' \#x 7 '!' #y 42 '!' 'defaults' +@ + +This is an infix version of 'with'. + +-} +(!) :: forall p fn fn'. WithParam p fn fn' => fn -> Param p -> fn' +fn ! p = with p fn +{-# INLINE (!) #-} + +infixl 9 ! + +{- | +Supply a parameter @p@ to a function @fn@, resulting in @fn'@. + +For example, when we pass a single named parameter, we get a function without +this parameter: + +@ +WithParam + ("x" :! Char) -- p + ("b" :! Bool -> "x" :! Char -> r) -- fn + ("b" :! Bool -> r) -- fn' +@ + +In case the parameter cannot be supplied, this constraint will become a type +error. + +-} +class WithParam p fn fn' | p fn -> fn' where + {- | Supply a parameter to a function: + + @ + 'with' (\#param_name value) function + @ + + @ + 'with' 'defaults' function + @ + + This is a prefix version of the ('!') operator. + + -} + with :: Param p -> fn -> fn' + +instance WithParam' (Decide p fn) p fn fn' => WithParam p fn fn' where + with (Param p) fn = withParam @(Decide p fn) p fn + {-# INLINE with #-} + +data Defaults = Defaults + +{- | +Passing 'defaults' to a function fills all unspecified optional parameters +with 'Nothing': + +@ +fn :: "b" ':!' Bool -> "x" ':?' Char -> Int -> IO () +fn '!' 'defaults' :: "b" ':!' Bool -> Int -> IO () +@ + +-} +defaults :: Param Defaults +defaults = Param Defaults + +{- | + +A proxy for a name, intended for use with @-XOverloadedLabels@: + +@ +#verbose :: Name "verbose" +@ + +-} + +data Name (name :: Symbol) = Name + +instance name ~ name' => IsLabel name' (Name name) where +#if MIN_VERSION_base(4,10,0) + fromLabel = Name +#else + fromLabel _ = Name +#endif + {-# INLINE fromLabel #-} + +{- | + +'arg' unwraps a named parameter with the specified name. One way to use it is +to match on arguments with @-XViewPatterns@: + +@ +fn (arg \#t -> t) (arg \#f -> f) = ... +@ + +This way, the names of parameters can be inferred from the patterns: no type +signature for @fn@ is required. In case a type signature for @fn@ is +provided, the parameters must come in the same order: + +@ +fn :: "t" :! Integer -> "f" :! Integer -> ... +fn (arg \#t -> t) (arg \#f -> f) = ... -- ok +fn (arg \#f -> f) (arg \#t -> t) = ... -- does not typecheck +@ + +-} +arg :: Name name -> name :! a -> a +arg _ (ArgF (Identity a)) = a +{-# INLINE arg #-} + +{- | + +'argF' is similar to 'arg': it unwraps a named parameter with the specified name. +The difference is that the result of 'argF' is inside an arity wrapper, +which is 'Identity' for normal parameters and 'Maybe' for optional parameters. + +-} +argF :: Name name -> NamedF f a name -> f a +argF _ (ArgF fa) = fa +{-# INLINE argF #-} + +{- | + +A variation of 'arg' for optional arguments. Requires a default value to handle +the case when the optional argument was omitted: + +@ +fn (argDef \#answer 42 -> ans) = ... +@ + +In case you want to get a value wrapped in 'Maybe' instead, use 'argF' or +'ArgF'. + +-} +argDef :: Name name -> a -> name :? a -> a +argDef _ d (ArgF fa) = fromMaybe d fa + +-------------------------------------------------------------------------------- +-- The working horses of the library: Decide and WithParam' +-------------------------------------------------------------------------------- + +data DApply +data DFill +data DPass + +type family Decide (p :: Type) (fn :: Type) :: [Type] where + Decide (NamedF f' a' name) (NamedF f a name -> r) = '[DApply] + Decide Defaults (NamedF Maybe a name -> r) = DFill : Decide Defaults r + Decide p (x -> r) = DPass : Decide p r + Decide (NamedF f' a' name) t = + TypeError (Text "Named parameter '" :<>: Text name :<>: + Text "' was supplied, but not expected") + Decide Defaults t = '[] + +class WithParam' (ds :: [Type]) p fn fn' | ds p fn -> fn' where + withParam :: p -> fn -> fn' + +instance fn ~ fn' => WithParam' '[] p fn fn' where + withParam _ = id + {-# INLINE withParam #-} + +instance + ( WithParam' ds p r r', + fn ~ (p -> r), + fn' ~ r' + ) => WithParam' (DApply : ds) p fn fn' + where + withParam p fn = withParam @ds p (fn p) + {-# INLINE withParam #-} + +instance + ( WithParam' ds p r r', + fn ~ (x -> r), + fn' ~ (x -> r') + ) => WithParam' (DPass : ds) p fn fn' + where + withParam a fn = \x -> withParam @ds a (fn x) + {-# INLINE withParam #-} + +instance + ( WithParam' ds p r r', + fn ~ (NamedF f x name -> r), + fn' ~ r', + f ~ Maybe + ) => WithParam' (DFill : ds) p fn fn' + where + withParam p fn = withParam @ds p (fn (ArgF Nothing)) + {-# INLINE withParam #-} diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,63 +1,96 @@ -{-# LANGUAGE OverloadedLabels, DataKinds, TypeOperators #-} - -module Main where - -import Data.Function ((&)) -import Named - -test1 :: - String -> - Flag "a" -> - Bool `Named` "b" -> - IO () -test1 "str" (Flag True) (Flag False) = return () -test1 _ _ _ = error "unexpected flags or str" - -test1_1 = - test1 "str" - ! #a True - ! #b False - -test1_2 = - test1 "str" - ! #b False - ! #a True - -test1_3 = - test1 "str" - & with #b False - & with #a True - -test1_4 = - with #a True $ - with #b False $ - test1 "str" - -test1_5 = - with #a True $ - test1 "str"! #b False - -test1_6 = - test1 "str"! #a True - & with #b False - -test2 :: Named Int "x" -> Int -test2 x = unnamed x * 2 - -test2_1 :: Int -test2_1 = test2 ! #x 5 + test2 ! #x 3 - -main :: IO () -main = do - test1_1 - test1_2 - test1_3 - test1_4 - test1_5 - test1_6 - test2_1 `mustBe` 16 - -mustBe :: (Eq a, Show a) => a -> a -> IO () -mustBe a b - | a == b = return () - | otherwise = error $ show a ++ " must be " ++ show b +{-# LANGUAGE OverloadedLabels, DataKinds, TypeOperators, ViewPatterns, + PartialTypeSignatures #-} + +{-# OPTIONS -fno-warn-partial-type-signatures #-} + +module Main where + +import Data.Maybe (fromMaybe) +import Data.Function ((&)) +import Named + +test1 :: + String -> + "a" :! Bool -> + "b" :! Bool -> + IO () +test1 "str" (arg #a -> True) (arg #b -> False) = return () +test1 _ _ _ = error "unexpected flags or str" + +test1_1 = + test1 "str" + ! #a True + ! #b False + +test1_2 = + test1 "str" + ! #b False + ! #a True + +test1_3 = + test1 "str" + & with (#b False) + & with (#a True) + +test1_4 = + with (#a True) $ + with (#b False) $ + test1 "str" + +test1_5 = + with (#a True) $ + test1 "str"! #b False + +test1_6 = + test1 "str"! #a True + & with (#b False) + +test2 :: "x" :! Int -> Int +test2 x = arg #x x * 2 + +test2_1 :: Int +test2_1 = test2 ! #x 5 + test2 ! #x 3 + +test3 (arg #a -> a) (arg #b -> b) = a + b + +-- must not typecheck: +-- Couldn't match type ‘"a"’ with ‘"b"’ +-- arising from the overloaded label ‘#b’ +-- +-- test3' :: _ => "a" :! _ -> _ :! "b" -> _ +-- test3' (arg #b -> a) (arg #a -> b) = a + b + +-- test4 :: +-- "b" :! Bool -> +-- NamedF _ Char "x" -> +-- "y" :? Char -> +-- Char +test4 + (arg #b -> b) + (argDef #x 'x' -> x) + (ArgF y) + = if b then x else (fromMaybe 'y' y) + +test4_1 = test4 ! #b True ! defaults +test4_2 = test4 ! #b False ! defaults +test4_3 = test4 ! #x 'z' ! #b True ! defaults +test4_4 = test4 ! defaults ! #b True + +main :: IO () +main = do + test1_1 + test1_2 + test1_3 + test1_4 + test1_5 + test1_6 + test2_1 `mustBe` 16 + test4_1 `mustBe` 'x' + test4_2 `mustBe` 'y' + test4_3 `mustBe` 'z' + test4_4 `mustBe` 'x' + +mustBe :: (Eq a, Show a) => a -> a -> IO () +mustBe a b + | a == b = return () + | otherwise = error $ show a ++ " must be " ++ show b