packages feed

apply-unordered (empty) → 1.0

raw patch · 7 files changed

+422/−0 lines, 7 filesdep +apply-unordereddep +basedep +fin

Dependencies added: apply-unordered, base, fin, ghc, ghc-tcplugins-extra, hspec, should-not-typecheck, syb

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.cabal view
@@ -0,0 +1,65 @@+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: 7c7261ca428b9ac4e6ff944f035a7ffb4fc7a91658e53c1e4e3847114fc71bde++name:           apply-unordered+version:        1.0+synopsis:       Apply a function to an argument specified by a type level Nat+description:    Please see the README on GitHub at <https://github.com/mgsloan/apply-unordered#readme>+category:       Functions, ACME, Compiler Plugin+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.Positional+      Control.Apply.Unordered+      Control.Apply.Unordered.Plugin+  other-modules:+      Paths_apply_unordered+  hs-source-dirs:+      src+  default-extensions: DataKinds FlexibleContexts FlexibleInstances MultiParamTypeClasses ScopedTypeVariables TypeApplications TypeFamilies TypeOperators PolyKinds+  build-depends:+      base >=4.9 && <5+    , fin >=0.1+    , ghc >=8.6+    , ghc-tcplugins-extra >=0.3+    , syb >=0.7+  default-language: Haskell2010++test-suite apply-positional-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_apply_unordered+  hs-source-dirs:+      test+  default-extensions: DataKinds FlexibleContexts FlexibleInstances MultiParamTypeClasses ScopedTypeVariables TypeApplications TypeFamilies TypeOperators PolyKinds+  ghc-options: -fplugin=Control.Apply.Unordered.Plugin+  build-depends:+      apply-unordered+    , base >=4.9 && <5+    , fin >=0.1+    , ghc >=8.6+    , ghc-tcplugins-extra >=0.3+    , hspec+    , should-not-typecheck+    , syb >=0.7+  default-language: Haskell2010
+ changelog.md view
@@ -0,0 +1,3 @@+# Changelog for positional-apply++## Unreleased changes
+ src/Control/Apply/Positional.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}++-- | FIXME+module Control.Apply.Positional+  ( applyN+  , applyN'+  , ApplyAt(ApplyAtResult)+  , CheckArity+  ) where++import GHC.Exts (Constraint)+import Data.Proxy (Proxy(..))+import Data.Type.Nat (Nat(..), FromGHC)+import GHC.TypeLits (TypeError, ErrorMessage(..))+import qualified GHC.TypeLits as GHC++-- | FIXME: document+--+-- NOTE: Only usable via TypeApplication+applyN+  :: forall (gn :: GHC.Nat) a f n.+     ( n ~ FromGHC gn+     , CheckArity gn f n f+     , ApplyAt n a f+     )+  => f -> a -> ApplyAtResult n a f+applyN = applyN' (Proxy :: Proxy gn)+{-# INLINE applyN #-}++-- | FIXME: document+applyN'+  :: forall (gn :: GHC.Nat) a f n.+     ( n ~ FromGHC gn+     , CheckArity gn f n f+     , ApplyAt n a f+     )+  => Proxy gn -> f -> a -> ApplyAtResult n a f+applyN' _ = applyAtImpl (Proxy :: Proxy n)+{-# INLINE applyN' #-}++-- | Typeclass used to implement 'applyN'. The first type argument is+-- the number of arguments to skip before doing the application.+class ApplyAt (n :: Nat) a f where+  type ApplyAtResult n a f+  applyAtImpl+    :: Proxy n+    -> f+    -> a+    -> ApplyAtResult n a f++instance a ~ b => ApplyAt Z a (b -> r) where+  type ApplyAtResult Z a (b -> r) = r+  applyAtImpl _ f x = f x+  {-# INLINE applyAtImpl #-}++instance ApplyAt n a r+      => ApplyAt (S n) a (b -> r) where+  type ApplyAtResult (S n) a (b -> r) = b -> ApplyAtResult n a r+  applyAtImpl _ f y = \x -> applyAtImpl (Proxy :: Proxy n) (f x) y+  {-# INLINE applyAtImpl #-}++type family CheckArity (n0 :: GHC.Nat) f0 (n :: Nat) f :: Constraint where+  CheckArity n0 f0 (S n) (_ -> r) = CheckArity n0 f0 n r+  CheckArity n0 f0 Z (_ -> r) = ()+  CheckArity n0 f0 (S n) r = TypeError (TooFewParametersMsg n0 f0)+  CheckArity n0 f0 Z r = TypeError (TooFewParametersMsg n0 f0)++type TooFewParametersMsg (n :: GHC.Nat) f =+  'Text "Cannot apply argument index " :<>: 'ShowType n :<>:+  'Text " of a function of type" :$$:+  'Text "  " :<>: 'ShowType f :$$:+  'Text "because it has too few arguments."
+ src/Control/Apply/Unordered.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE UndecidableInstances #-}++module Control.Apply.Unordered where++import GHC.TypeLits (TypeError, ErrorMessage(..))+import qualified GHC.TypeLits as GHC+import Data.Proxy+import Data.Type.Nat (Nat(..), FromGHC)++import Control.Apply.Positional++infixl 1 ?++(?)+  :: forall a f gn n.+     ( gn ~ BestParamIxImpl a f+     , n ~ FromGHC gn+     , CheckArity gn f n f+     , ApplyAt n a f+     )+  => f -> a -> ApplyAtResult n a f+(?) = applyN' (Proxy :: Proxy gn)++type family BestParamIxImpl (a :: *) (f :: *) :: GHC.Nat where++{- TODO: Might be handy for other users of this to++type BestParamIx a f = RaiseError (BestParamIxImpl a f)++type family RaiseError (a :: Either ErrorMessage k) :: k where+  RaiseError (Left msg) = TypeError msg+  RaiseError (Right x) = x++type family BestParamIxImpl (a :: *) (f :: *) :: Either ErrorMessage GHC.Nat where+  BestParamIxImpl _ _ = TypeError PluginNotEnabledErrorMsg+-}+++{- FIXME: use the stuckness hack++  BestParamIxImpl _ _ = TypeError PluginNotEnabledErrorMsg++type PluginNotEnabledErrorMsg =+  'Text "The unordered apply plugin isn't enabled." :$$:+  'Text "  Fix: import and enable '-fplugin=Control.Apply.Unordered.Plugin'"+-}
+ src/Control/Apply/Unordered/Plugin.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE LambdaCase #-}++-- TODO: Cleanup this module, right now it's just the state at the end+-- of a hacking session to bring it to proof-of-concept.+module Control.Apply.Unordered.Plugin where++import Control.Monad (guard)+import Data.Generics (everything, mkQ)+import Data.Traversable (for)+import GHC.TcPluginM.Extra (lookupModule, lookupName, evByFiat)+import Data.Maybe++import GhcPlugins+import TcEvidence (EvTerm (..))+import TcPluginM (TcPluginM, tcLookupTyCon, newGiven)+import TcRnTypes+import TcType (isTyFamFree)+import Unify (tcMatchTy)+import TyCoRep++plugin :: Plugin+plugin = defaultPlugin+  { tcPlugin = const $ Just $ TcPlugin+      { tcPluginInit = initContext+      , tcPluginSolve = \context _ _ ->+          fmap (TcPluginOk []) . solveWanteds (implementTyFam context) (familyTyCon context)+      , tcPluginStop = const $ pure ()+      }+  , pluginRecompile = const $ pure NoForceRecompile+  }++data Context = Context+  { familyTyCon :: TyCon+  , typeErrorTyCon :: TyCon+  {-+  , textTyCon :: TyCon+  , showTypeTyCon :: TyCon+  -}+  }++initContext :: TcPluginM Context+initContext = Context+  <$> loadTyCon+        "apply-unordered"+        "Control.Apply.Unordered"+        "BestParamIxImpl"+  <*> loadTyCon+        "base"+        "GHC.TypeLits"+        "TypeError"+        {-+  <*> loadTyCon+        "base"+        "GHC.TypeLits"+        "Text"+  <*> loadTyCon+        "base"+        "GHC.TypeLits"+        "ShowType"+-}++implementTyFam :: Context -> [Type] -> Maybe Type+implementTyFam context [a, b] = do+  -- TODO: Are these guards really necessary? Useful to be able to+  -- ignore stuckness?+  guard $ isTyFamFree a+  guard $ isTyFamFree b+  pure $ promoteBestMatchResult context $ findBestMatch a b++promoteBestMatchResult :: Context -> BestMatchResult -> Type+promoteBestMatchResult context = \case+  BestMatch n -> LitTy (NumTyLit n)+  -- FIXME: Emit TypeError instead+  AmbiguousMatch _ -> error "Ambiguous"+  NoMatch -> error "No match"++data BestMatchResult+  = BestMatch Integer+  | AmbiguousMatch [(Integer, Type)]+  | NoMatch++findBestMatch :: Type -> Type -> BestMatchResult+findBestMatch arg fun =+--  case foldr addMatch [] (pprTraceIt "candidates" (candidateMatches (pprTraceIt "arg" arg) 0 (pprTraceIt "fun" fun))) of+  case foldr addMatch [] (candidateMatches arg 0 fun) of+    [] -> NoMatch+    [(ix, _)] -> BestMatch ix+    matches -> AmbiguousMatch matches++-- This logic was directly inspired by the function insert_overlapping+-- in ghc/compiler/types/InstEnv.hs+addMatch :: (Integer, Type) -> [(Integer, Type)] -> [(Integer, Type)]+addMatch new_item [] = [new_item]+addMatch new_item (old_item : old_items)+  -- New strictly overrides old+  | new_beats_old+  , not old_beats_new+  = addMatch new_item old_items++  -- Old strictly overrides new+  | old_beats_new+  , not new_beats_old+  = old_item : old_items++  | otherwise+  = old_item : addMatch new_item old_items+  where+    new_beats_old = snd new_item `more_specific_than` snd old_item+    old_beats_new = snd old_item `more_specific_than` snd new_item++    -- | l can be instantiated to match r, or they are equal+    more_specific_than :: Type -> Type -> Bool+    more_specific_than l r = isJust (tcMatchTy r l)++candidateMatches :: Type -> Integer -> Type -> [(Integer, Type)]+candidateMatches arg ix = \case+  FunTy paramTy resultTy+    | isJust (tcMatchTy paramTy arg) ->+        (ix, paramTy) : candidateMatches arg (ix + 1) resultTy+    | otherwise ->+        candidateMatches arg (ix + 1) resultTy++  -- TODO: Does GHC ever represent function types using TyConApp?+  TyConApp{} -> []++  -- TODO: Handle forall.+  ForAllTy{} -> []++  CastTy ty _ -> candidateMatches arg ix ty+  TyVarTy{} -> []+  AppTy{} -> []+  CoercionTy{} -> []++-- | Get your hands on the type constructor for your type family.+loadTyCon+    :: String  -- ^ package+    -> String  -- ^ module+    -> String  -- ^ identifier+    -> TcPluginM TyCon+loadTyCon p m i = do+  md <- lookupModule (mkModuleName m) $ fsLit p+  nm <- lookupName md $ mkTcOcc i+  tcLookupTyCon nm++-- | @solveWanteds f tyfam cts@ finds all instaces of @tyfam@ inside the wanted+-- constraints @cts@, and evaluates them via @f@. The result is a set of+-- 'CNonCanonical' constraints, which should be emitted as the second parameter+-- of 'TcPluginOk'.+solveWanteds+  :: ([Type] -> Maybe Type)+  -> TyCon+  -> [Ct]+  -> TcPluginM [Ct]+solveWanteds _ _ [] = pure []+solveWanteds f familyTyCon wanteds = do+  let rel = map (\wanted -> findRelevant f familyTyCon (ctLoc wanted) (ctev_pred (cc_ev wanted))) wanteds++  gs <- for (concat rel) $ \(MagicTyFamResult loc t res) -> do+    let EvExpr ev = evByFiat "magic-tyfams" t res+    newGiven loc (mkPrimEqPred t res) ev++  pure $ fmap CNonCanonical gs++-- | Locate and expand the use of any type families.+findRelevant :: ([Type] -> Maybe Type) -> TyCon -> CtLoc -> Type -> [MagicTyFamResult]+findRelevant f familyTyCon loc = everything (++) $ mkQ [] findCmpType+  where+    findCmpType t =+      case splitTyConApp_maybe t of+        Just (tc, ts) | tc == familyTyCon ->+           maybe [] (pure . MagicTyFamResult loc t) $ f ts+        _ -> []++data MagicTyFamResult = MagicTyFamResult+  { _mtfrLoc      :: CtLoc+  , _mtfrOriginal :: Type+  , _mtfrSolved   :: Type+  }
+ test/Spec.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}+{-# OPTIONS_GHC -fplugin=Control.Apply.Unordered.Plugin #-}++module Main where++import Control.Apply.Positional+import Control.Apply.Unordered+import Data.Proxy+import GHC.TypeLits+import Test.Hspec+import Test.ShouldNotTypecheck (shouldNotTypecheck)++replicateChar :: Int -> Char -> String+replicateChar = replicate++main :: IO ()+main = hspec $ do+  describe "Positional application" $ do+    it "handles simple functions" $+      applyN @1 replicateChar 'c' 3 `shouldBe` "ccc"+    it "handles polymorphic functions" $+      applyN @1 div 2 4 `shouldBe` 2+    it "yields type error for out of bounds nats" $+      shouldNotTypecheck (applyN @2 replicateChar 'c' 3 :: String)+  describe "Unordered apply via plugin" $ do+    it "Can match types of a polymorphic function" $+      (replicate ? 'c' ? (3 :: Int)) `shouldBe` "ccc"