packages feed

apply-unordered-mono (empty) → 1.0

raw patch · 5 files changed

+403/−0 lines, 5 filesdep +apply-unordered-monodep +basedep +hspec

Dependencies added: apply-unordered-mono, base, hspec, should-not-typecheck

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Michael Sloan (c) 2019++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 Michael Sloan 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.
+ apply-unordered-mono.cabal view
@@ -0,0 +1,54 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8341a9984a6406c1431dfdd77f2dc37a93af1e7689504c5601a2f387c2b5a17c++name:           apply-unordered-mono+version:        1.0+synopsis:       Apply functions to arguments in an unordered type-directed fashion+description:    Please see the README on GitHub at <https://github.com/mgsloan/apply-unordered#readme>+category:       Functions, ACME+homepage:       https://github.com/mgsloan/apply-unordered#readme+bug-reports:    https://github.com/mgsloan/apply-unordered/issues+author:         Michael Sloan+maintainer:     mgsloan@gmail.com+copyright:      2019 Michael Sloan+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    changelog.md++source-repository head+  type: git+  location: https://github.com/mgsloan/apply-unordered++library+  exposed-modules:+      Control.Apply.Unordered.Mono+  other-modules:+      Paths_apply_unordered_mono+  hs-source-dirs:+      src+  default-extensions: DataKinds FlexibleContexts FlexibleInstances MultiParamTypeClasses ScopedTypeVariables TypeFamilies TypeOperators+  build-depends:+      base >=4.9 && <5+  default-language: Haskell2010++test-suite apply-unordered-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_apply_unordered_mono+  hs-source-dirs:+      test+  default-extensions: DataKinds FlexibleContexts FlexibleInstances MultiParamTypeClasses ScopedTypeVariables TypeFamilies TypeOperators+  build-depends:+      apply-unordered-mono+    , base >=4.9 && <5+    , hspec+    , should-not-typecheck+  default-language: Haskell2010
+ changelog.md view
@@ -0,0 +1,3 @@+# Changelog for apply-unordered-mono++## Unreleased changes
+ src/Control/Apply/Unordered/Mono.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE UndecidableInstances #-}++-- | This modules is an experiment in type family / typeclass+-- machinery to provide type-directed function application and+-- argument reordering. It is severely restricted, in that it only+-- supports monomorphic arguments and parameters.+--+-- Few commonly known functions in base are monomorphic with multiple+-- arguments, so I will use an example from @ Data.Text @:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import qualified Data.Text as T+-- >+-- > ex1 :: Int -> T.Text+-- > ex1 = T.replicate ? ("wow! " :: Text)+--+-- Cool! The '(?)' operator has magically provided the 2nd argument of+-- @T.replicate@ (its type is @Int -> Text -> Text@).+--+-- This module also provides `reorderArgs`, which does this variety of+-- function application in a variadic fashion.+--+-- > ex2 :: T.Text -> Int -> T.Text+-- > ex2 = reorderArgs T.replicate+module Control.Apply.Unordered.Mono+  (+    -- * Type-directed function application which uses first match+    applyByType+  , reorderArgs+  , (?)+    -- * Type-directed function application which requires unique match+  , applyByUniqueType+  , reorderUniqueArgs+  , (?!)+    -- * Machinery for type directed function application+  , MatchArgResult(..)+  , MatchFirstArg+  , HasAMatch+  , ApplyByType(ApplyByTypeResult)+    -- * Machinery for unique match function application+  , HasUniqueMatch+  , CheckAmbiguousMatch+    -- * Machinery for reordering parameters+  , HasArgResult(..)+  , HasArg+  , ReorderArgs+  , ReorderUniqueArgs+  ) where++import Data.Proxy (Proxy(..))+import GHC.TypeLits (TypeError, ErrorMessage(..))++-- | Applies a function to an argument, by providing the argument to+-- the first parameter which matches the argument type. This does not+-- handle any polymorphism in the function type or any argument types.+applyByType+  :: forall a f matches.+     ( matches ~ HasAMatch a f f+     , ApplyByType matches a f+     )+  => f -> a -> ApplyByTypeResult matches a f+applyByType = applyByTypeImpl (Proxy :: Proxy matches)+{-# INLINE applyByType #-}++infixl 1 ?++-- | Operator alias for 'applyByType'+(?)+  :: forall a f matches.+     ( matches ~ HasAMatch a f f+     , ApplyByType matches a f+     )+  => f -> a -> ApplyByTypeResult matches a f+(?) = applyByType+{-# INLINE (?) #-}++-- | Similarly to 'applyByType', applies a function to an argument by+-- matching the argument type with the parameter type. If the match is+-- ambiguous, this is a type error.+applyByUniqueType+  :: forall a f matches.+     ( matches ~ HasUniqueMatch a f f+     , ApplyByType matches a f+     )+  => f -> a -> ApplyByTypeResult matches a f+applyByUniqueType = applyByTypeImpl (Proxy :: Proxy matches)+{-# INLINE applyByUniqueType #-}++infixl 1 ?!++-- | Operator alias for 'applyByUniqueType'+(?!)+  :: forall a f matches.+     ( matches ~ HasUniqueMatch a f f+     , ApplyByType matches a f+     )+  => f -> a -> ApplyByTypeResult matches a f+(?!) = applyByUniqueType+{-# INLINE (?!) #-}++reorderArgs :: forall f g. ReorderArgs (HasArg f) f g => f -> g+reorderArgs = reorderArgsImpl (Proxy :: Proxy (HasArg f))+{-# INLINE reorderArgs #-}++reorderUniqueArgs :: forall f g. ReorderUniqueArgs (HasArg f) f g => f -> g+reorderUniqueArgs = reorderUniqueArgsImpl (Proxy :: Proxy (HasArg f))+{-# INLINE reorderUniqueArgs #-}++--------------------------------------------------------------------------------+-- Match machinery++-- | A data-kind for 'MatchArgResult' to return.+data MatchArgResult+  = Matches         -- ^ Indicates the first argument matches.+  | Doesn'tMatch    -- ^ Indicates the first argument doesn't match.+  | NoArgToMatch    -- ^ Indicates the function has no first argument.++-- | A type family which checks if the specified argument type matches+-- the first parameter of a function.+type family MatchFirstArg a f :: MatchArgResult where+  MatchFirstArg a (a -> _) = 'Matches+  MatchFirstArg a (b -> _) = 'Doesn'tMatch+  MatchFirstArg _ _ = 'NoArgToMatch++-- | A type family which returns a 'TypeError', specifically+-- 'NoMatchErrorMsg', if the specified argument type matches none of+-- the function parameter types. Otherwise, it behaves the same as+-- 'MatchFirstArg'.+type family HasAMatch a f f0 :: MatchArgResult where+  HasAMatch a (a -> _) f0 = MatchFirstArg a f0+  HasAMatch a (b -> r) f0 = HasAMatch a r f0+  HasAMatch a _ f0 = TypeError (NoMatchErrorMsg a f0)++-- | Typeclass used to implement 'applyByType'. The first type+-- argument is used to select instances, and should always be+-- @MatchFirstArg a f@.+class ApplyByType (matches :: MatchArgResult) a f where+  type ApplyByTypeResult matches a f+  applyByTypeImpl+    :: Proxy matches+    -> f+    -> a+    -> ApplyByTypeResult matches a f++instance ApplyByType 'Matches a (a -> r) where+  type ApplyByTypeResult 'Matches a (a -> r) = r+  applyByTypeImpl _ f x = f x+  {-# INLINE applyByTypeImpl #-}++instance ApplyByType (MatchFirstArg a r) a r+      => ApplyByType 'Doesn'tMatch a (b -> r) where+  type ApplyByTypeResult 'Doesn'tMatch a (b -> r) =+    b -> ApplyByTypeResult (MatchFirstArg a r) a r+  applyByTypeImpl _ f y =+    \x -> applyByTypeImpl (Proxy :: Proxy (MatchFirstArg a r)) (f x) y+  {-# INLINE applyByTypeImpl #-}++instance TypeError (NoMatchForResultErrorMsg a r)+      => ApplyByType 'NoArgToMatch a r where+  type ApplyByTypeResult 'NoArgToMatch a r =+    TypeError (NoMatchForResultErrorMsg a r)+  applyByTypeImpl = error "impossible"++--------------------------------------------------------------------------------+-- Unique match machinery++-- | A type family similar to 'HasAMatch', but also checks that+-- there's a unique match for the argument type.+type family HasUniqueMatch a f f0 :: MatchArgResult where+  HasUniqueMatch a (a -> r) f0 = CheckAmbiguousMatch a r f0+  HasUniqueMatch a (b -> r) f0 = HasUniqueMatch a r f0+  HasUniqueMatch a _ f0 = TypeError (NoMatchErrorMsg a f0)++-- | Used to implement 'HasUniqueMatch', this type family is used+-- after the match is found. Any additional matches cause an+-- 'AmbiguousMatchErrorMsg'.+type family CheckAmbiguousMatch a f f0 :: MatchArgResult where+  CheckAmbiguousMatch a (a -> _) f0 = TypeError (AmbiguousMatchErrorMsg a f0)+  CheckAmbiguousMatch a (b -> r) f0 = CheckAmbiguousMatch a r f0+  CheckAmbiguousMatch a _ f0 = MatchFirstArg a f0++--------------------------------------------------------------------------------+-- Argument reordering machinery++-- | A data-kind for 'HasArg' to return.+data HasArgResult+  = ArgPresent    -- ^ Indicates that the type is a function type.+  | NoArg         -- ^ Indicates that the type is not a function type.++-- | Checks whether the specified type is a function type ( @ -> @ ).+type family HasArg f :: HasArgResult where+  HasArg (_ -> _) = 'ArgPresent+  HasArg _ = 'NoArg++-- | Typeclass used to implement 'reorderArgs'. The first type+-- argument is used to select instances, and should always be @HasArg+-- f@.+class ReorderArgs (fHasArg :: HasArgResult) f g where+  reorderArgsImpl :: Proxy fHasArg -> f -> g++instance+    ( matches ~ HasAMatch a (b -> y) (b -> y)+    , result ~ ApplyByTypeResult matches a (b -> y)+    , ApplyByType matches a (b -> y)+    , ReorderArgs (HasArg result) result x+    ) => ReorderArgs 'ArgPresent (b -> y) (a -> x) where+  reorderArgsImpl _ f x =+    reorderArgsImpl (Proxy :: Proxy (HasArg result)) $+    applyByType f x+  {-# INLINE reorderArgsImpl #-}++instance r1 ~ r2 => ReorderArgs 'NoArg r1 r2 where+  reorderArgsImpl _ f = f+  {-# INLINE reorderArgsImpl #-}++-- | Typeclass used to implement 'reorderUniqueArgs'. The first type+-- argument is used to select instances, and should always be @HasArg+-- f@.+class ReorderUniqueArgs (fHasArg :: HasArgResult) f g where+  reorderUniqueArgsImpl :: Proxy fHasArg -> f -> g++instance+    ( matches ~ HasUniqueMatch a (b -> y) (b -> y)+    , result ~ ApplyByTypeResult matches a (b -> y)+    , ApplyByType matches a (b -> y)+    , ReorderUniqueArgs (HasArg result) result x+    ) => ReorderUniqueArgs 'ArgPresent (b -> y) (a -> x) where+  reorderUniqueArgsImpl _ f x =+    reorderUniqueArgsImpl (Proxy :: Proxy (HasArg result)) $+    applyByUniqueType f x+  {-# INLINE reorderUniqueArgsImpl #-}++instance r1 ~ r2 => ReorderUniqueArgs 'NoArg r1 r2 where+  reorderUniqueArgsImpl _ f = f+  {-# INLINE reorderUniqueArgsImpl #-}++--------------------------------------------------------------------------------+-- Type error messages++type NoMatchErrorMsg a f =+  'Text "Parameter type " ':$$:+  'Text "  " ':<>: 'ShowType a ':$$:+  'Text "does not occur in the arguments of the function type " ':$$:+  'Text "  " ':<>: 'ShowType f ':$$:+  'Text "and so cannot be applied via type directed application."++-- This case may not be necessary, but I recall having examples where+-- it happens instead of NoMatchErrorMsg.  Unfortunately, I don't seem+-- to have written down those examples.++type NoMatchForResultErrorMsg a r =+  'Text "Parameter type " ':$$:+  'Text "  " ':<>: 'ShowType a ':$$:+  'Text "does not occur in the arguments of the function that returns " ':$$:+  'Text "  " ':<>: 'ShowType r ':$$:+  'Text "and so cannot be applied via type directed application."++type AmbiguousMatchErrorMsg a f =+  'Text "Parameter type " ':$$:+  'Text "  " :<>: 'ShowType a ':<>:+  'Text " occurs multiple times in the arguments of the function type " ':$$:+  'Text "  " ':<>: 'ShowType f ':$$:+  'Text "and so cannot be applied via unique type directed application."
+ test/Spec.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}++module Main where++import Control.Apply.Unordered.Mono+import Test.Hspec+import Test.ShouldNotTypecheck (shouldNotTypecheck)++replicateChar :: Int -> Char -> String+replicateChar = replicate++polymorphicReturn :: Int -> Char -> Maybe a+polymorphicReturn _ _ = Nothing++threeArgs :: Int -> Char -> Bool -> String+threeArgs a b c = show (a, b, c)++i3 :: Int+i3 = 3++main :: IO ()+main = hspec $ do+  describe "Type directed apply with first match" $ do+    it "handles simple parameters (1)" $+      (replicateChar ? 'a' ? i3) `shouldBe` "aaa"+    it "handles simple parameters (2)" $+      (replicateChar ? i3 ? 'a') `shouldBe` "aaa"+    it "handles simple ambiguous parameters (1)" $+      ((||) ? True ? False) `shouldBe` True+    it "handles simple ambiguous parameters (2)" $+      ((||) ? False ? False) `shouldBe` False+    it "errors when there is no match" $+      shouldNotTypecheck ((||) ? "test")+    it "doesn't handle any parameter polymorphism" $+      shouldNotTypecheck (replicate ? 3 $ 'a' :: String)+    it "does handle result polymorphism" $+      (polymorphicReturn ? i3 $ 'a') `shouldBe` Nothing++  describe "Type directed apply with unique match" $ do+    it "handles simple parameters (1)" $+      (replicateChar ?! 'a' ?! i3) `shouldBe` "aaa"+    it "handles simple parameters (2)" $+      (replicateChar ?! i3 ?! 'a') `shouldBe` "aaa"+    it "checks for ambiguity" $+      shouldNotTypecheck ((||) ?! True ?! False :: Bool)+    it "errors when there is no match" $+      shouldNotTypecheck (replicateChar ? "test")++  describe "Argument reordering" $ do+    it "can re-order a 3 argument function (1)" $+      reorderArgs threeArgs 'a' i3 True `shouldBe` "(3,'a',True)"+    it "can re-order a 3 argument function (2)" $+      reorderArgs threeArgs False 'b' i3 `shouldBe` "(3,'b',False)"