named 0.1.0.0 → 0.2.0.0
raw patch · 7 files changed
+638/−409 lines, 7 filesdep ~basesetup-changednew-uploader
Dependency ranges changed: base
Files
- ChangeLog.md +12/−3
- LICENSE +30/−30
- Setup.hs +2/−2
- named.cabal +60/−56
- src/Named.hs +176/−255
- src/Named/Internal.hs +262/−0
- test/Test.hs +96/−63
ChangeLog.md view
@@ -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.
LICENSE view
@@ -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.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
named.cabal view
@@ -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 <vlad.z.4096@gmail.com> -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 <vlad.z.4096@gmail.com>+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
src/Named.hs view
@@ -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
+ src/Named/Internal.hs view
@@ -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 #-}
test/Test.hs view
@@ -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