overload 0.1.0.0 → 0.1.0.1
raw patch · 8 files changed
+245/−140 lines, 8 filesdep +containersdep +th-expand-syns
Dependencies added: containers, th-expand-syns
Files
- LICENSE +5/−26
- overload.cabal +7/−1
- src/Overload.hs +34/−113
- src/Overload/Diff.hs +54/−0
- src/Overload/Example.hs +10/−0
- src/Overload/General.hs +51/−0
- src/Overload/Normal.hs +34/−0
- src/Overload/TypeTree.hs +50/−0
LICENSE view
@@ -1,30 +1,9 @@-Copyright Author name here (c) 2017--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:+The MIT License (MIT) - * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.+Copyright (c) 2017 Luka Horvat - * 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.+Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: - * Neither the name of Author name here nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.+The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. -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.+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
overload.cabal view
@@ -1,5 +1,5 @@ name: overload-version: 0.1.0.0+version: 0.1.0.1 synopsis: Finite overloading description: Provides a mechanism for finite overloading homepage: https://gitlab.com/LukaHorvat/overload@@ -16,9 +16,15 @@ hs-source-dirs: src exposed-modules: Overload other-modules: Overload.Example+ Overload.TypeTree+ Overload.Normal+ Overload.General+ Overload.Diff build-depends: base >= 4.7 && < 5 , template-haskell , simple-effects+ , containers+ , th-expand-syns default-language: Haskell2010 ghc-options: -Wall
src/Overload.hs view
@@ -32,134 +32,56 @@ -- Notice that we didn't have to annotate anything. For the function case it was enough to use -- 'f' as a function. Since there's only one overload that's a function, the argument and -- the return value are inferred as 'Int's. -{-# LANGUAGE FlexibleContexts, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables, TypeApplications, AllowAmbiguousTypes, TemplateHaskell #-} +{-# LANGUAGE TupleSections, LambdaCase #-} module Overload (overload) where import Language.Haskell.TH import Data.Char -import Data.List (lookup, nub) import Control.Arrow -import Data.Functor.Identity import Data.Function - -import Control.Effects.State - -data TypeTree name = Var name | Concrete Name | App (TypeTree name) (TypeTree name) - deriving (Eq, Ord, Show, Functor, Foldable, Traversable) - -type FreshSource a = ([(a, Int)], Int) - -lookupName :: (MonadEffectState (FreshSource a) m, Eq a) => a -> m Int -lookupName name = do - (table, top) <- getState - case lookup name table of - Nothing -> do - setState ((name, top) : table, top + 1) - return top - Just n -> return n - -freshVar :: forall a m. MonadEffectState (FreshSource a) m => m Int -freshVar = do - (table, top) :: FreshSource a <- getState - setState (table, top + 1) - return top - -typeToTypeTree :: Type -> TypeTree Name -typeToTypeTree (ConT n) = Concrete n -typeToTypeTree (AppT t1 t2) = App (typeToTypeTree t1) (typeToTypeTree t2) -typeToTypeTree (VarT n) = Var n -typeToTypeTree (InfixT t1 n t2) = - App (App (Concrete n) (typeToTypeTree t1)) (typeToTypeTree t2) -typeToTypeTree ArrowT = Concrete (''(->)) -typeToTypeTree t = error ("Non supported type " ++ show t) - -allGeneralizations :: TypeTree a -> [TypeTree (Maybe a)] -allGeneralizations (Var n) = [Var Nothing, Var (Just n)] -allGeneralizations (Concrete n) = [Var Nothing, Concrete n] -allGeneralizations (App t1 t2) = - Var Nothing : (App <$> allGeneralizations t1 <*> allGeneralizations t2) - -normalizeTypeTree :: forall a. Eq a => TypeTree (Maybe a) -> TypeTree Int -normalizeTypeTree = - runIdentity . handleStateT (([], 0) :: FreshSource a) . traverse (maybe (freshVar @a) lookupName) - -type VariableMapping a b = [(a, TypeTree b)] - -trySetVar :: (MonadEffectState (VariableMapping a b) m, Eq a, Eq b) => a -> TypeTree b -> m Bool -trySetVar name typ = do - mapping <- getState - case lookup name mapping of - Just typ' | typ == typ' -> return True - | otherwise -> return False - Nothing -> do - setState ((name, typ) : mapping) - return True +import Control.Monad +import Language.Haskell.TH.ExpandSyns -isMoreGeneralThan :: forall a b. (Eq a, Eq b) => TypeTree a -> TypeTree b -> Bool -isMoreGeneralThan t1 t2 = - runIdentity (handleStateT ([] :: VariableMapping a b) (isMoreGeneralThan' t1 t2)) +import Overload.Normal +import Overload.TypeTree +import Overload.General +import qualified Overload.Diff as Diff -isMoreGeneralThan' :: (MonadEffectState (VariableMapping a b) m, Eq a, Eq b) - => TypeTree a -> TypeTree b -> m Bool -isMoreGeneralThan' (Var n) t = trySetVar n t -isMoreGeneralThan' (Concrete n1) (Concrete n2) | n1 == n2 = return True -isMoreGeneralThan' (App t1 t2) (App t3 t4) = - (&&) <$> t1 `isMoreGeneralThan'` t3 <*> t2 `isMoreGeneralThan'` t4 -isMoreGeneralThan' _ _ = return False +-- diff :: TypeTree a -> TypeTree a -> withouts :: [a] -> [(a, [a])] withouts [] = [] withouts (x : xs) = (x, xs) : map (second (x :)) (withouts xs) -minimize :: [TypeTree Int] -> [TypeTree Int] -minimize types = types & withouts - & filter (\(t, rest) -> not (any (`isMoreGeneralThan` t) rest)) - & map fst - -findDeciders :: Eq a => [TypeTree a] -> [[TypeTree Int]] -findDeciders types = fmap minimize viableInstances +allDeciders :: Eq a => [TypeTree a] -> [[TypeTree Normal]] +allDeciders types = + normalized & withouts + & map (\(t, rest) -> + t & (`Diff.deciders` rest) + & fmap normalizeTypeTree + & minimize + ) where normalized = fmap (normalizeTypeTree . fmap Just) types - viableInstances = - normalized & withouts - & map (\(t, rest) -> - t & allGeneralizations - & fmap normalizeTypeTree - & nub - & filter (\g -> not (any (g `isMoreGeneralThan`) rest)) - ) -typeTreeWithNames :: Show a => TypeTree a -> TypeTree Name -typeTreeWithNames = fmap (\a -> mkName ("t" ++ show a)) - -getEqualities :: forall a b. (Eq a, Eq b) => TypeTree a -> TypeTree b -> [(b, TypeTree a)] -getEqualities specific general = runIdentity $ handleStateT ([] :: VariableMapping b a) $ do - res <- general `isMoreGeneralThan'` specific - if res then getState - else error "Can't get equalities because the second type isn't more general than the first" - -typeTreeToType :: TypeTree Name -> Type -typeTreeToType (Var n) = VarT n -typeTreeToType (Concrete n) | n == ''(->) = ArrowT -typeTreeToType (Concrete n) = ConT n -typeTreeToType (App t1 t2) = AppT (typeTreeToType t1) (typeTreeToType t2) - equalityToCxt :: [(Name, TypeTree Name)] -> Cxt equalityToCxt = fmap (\(n, t) -> AppT (AppT EqualityT (VarT n)) (typeTreeToType t)) -deciders :: [(Name, Type)] -> [(Name, Cxt, Type)] -deciders cases = - concat (zipWith insts - (findDeciders (map (\(_, _, t) -> t) triplets)) - triplets) - where triplets = - cases & map (\(n, t) -> case t of - ForallT _ c t' -> (n, c, typeToTypeTree t') - t' -> (n, [], typeToTypeTree t')) - insts decs t = fmap (inst t . typeTreeWithNames) decs - inst (n, c, t) dec = (n, c ++ equalityToCxt eqs, typeTreeToType dec) - where eqs = getEqualities t dec +deciders :: [(Name, Type)] -> Q [(Name, Cxt, Type)] +deciders cases = do + let triplets = cases & map (\(n, t) -> case t of + ForallT _ c t' -> (n, c, t') + t' -> (n, [], t')) + seeds <- forM triplets $ \(_, _, t) -> + normalizeTypeTree <$> typeToTypeTree (const (Var Nothing)) Just t + concat <$> zipWithM insts + (allDeciders seeds) + triplets + where insts decs t = mapM (inst t . typeTreeWithNames) decs + inst (n, c, t) dec = do + tree <- typeToTypeTree Concrete id t + let eqs = getEqualities tree dec + return (n, c ++ equalityToCxt eqs, typeTreeToType dec) makeInstance :: Name -> Name -> (Name, Cxt, Type) -> Dec @@ -171,10 +93,9 @@ overload :: String -> [Name] -> Q [Dec] overload functionName overloadNames = do infos <- mapM reify overloadNames - let overloads = [(n, t) | VarI n t _ <- infos] - className = toUpper (head functionName) : tail functionName + overloads <- sequence [(n,) <$> expandSyns t | VarI n t _ <- infos] + let className = toUpper (head functionName) : tail functionName classDec = ClassD [] (mkName className) [PlainTV (mkName "t")] [] [SigD (mkName functionName) (VarT (mkName "t"))] - instances = fmap (makeInstance (mkName className) (mkName functionName)) - (deciders overloads) + instances <- fmap (makeInstance (mkName className) (mkName functionName)) <$> deciders overloads return (classDec : instances)
+ src/Overload/Diff.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE LambdaCase #-} +module Overload.Diff where + +import qualified Data.Set as Set +import Data.List (foldl1') +import Data.Either (partitionEithers) +import Debug.Trace + +import Overload.TypeTree + +data DiffStep = GoLeft | GoRight deriving (Eq, Ord, Read, Show) +type Diff = [DiffStep] + +wholeTreeDiff :: TypeTree a -> [Diff] +wholeTreeDiff (Var _) = [] +wholeTreeDiff (Concrete _) = [[]] +wholeTreeDiff (App t1 t2) = + fmap (GoLeft :) (wholeTreeDiff t1) ++ fmap (GoRight :) (wholeTreeDiff t2) + +diff :: TypeTree a -> TypeTree b -> [Diff] +diff (Var _) _ = [] +diff _ (Var _) = [] +diff (Concrete t1) (Concrete t2) | t1 /= t2 = [[]] + | otherwise = [] +diff (Concrete _) (App _ _) = [[]] +diff (App t1 t2) (App t3 t4) = fmap (GoLeft :) (diff t1 t3) ++ fmap (GoRight :) (diff t2 t4) +diff (App t1 t2) (Concrete _) = [] : wholeTreeDiff (App t1 t2) + +treeFromDiff :: Diff -> TypeTree a -> TypeTree (Maybe a) +treeFromDiff [] (Var n) = Var (Just n) +treeFromDiff [] (Concrete t) = Concrete t +treeFromDiff [] (App _ _) = App (Var Nothing) (Var Nothing) +treeFromDiff (GoLeft : ds) (App t _) = App (treeFromDiff ds t) (Var Nothing) +treeFromDiff (GoRight : ds) (App _ t) = App (Var Nothing) (treeFromDiff ds t) +treeFromDiff _ _ = error "Invalid diff for type tree" + +diffToEither :: Diff -> Either Diff Diff +diffToEither (GoLeft : ds) = Left ds +diffToEither (GoRight : ds) = Right ds +diffToEither _ = error "Can't convert an empty diff into an Either" + +treeFromDiffs :: [Diff] -> TypeTree a -> TypeTree (Maybe a) +treeFromDiffs [] _ = Var Nothing +treeFromDiffs ds (Var n) | all null ds = Var (Just n) + | otherwise = error "Diff is trying to go through a leaf" +treeFromDiffs ds (Concrete t) | all null ds = Concrete t + | otherwise = error "Diff is trying to go through a leaf" +treeFromDiffs ds (App t1 t2) = + App (treeFromDiffs lefts t1) (treeFromDiffs rights t2) + where (lefts, rights) = partitionEithers (fmap diffToEither (filter (not . null) ds)) + +deciders :: TypeTree a -> [TypeTree b] -> [TypeTree (Maybe a)] +deciders t [] = fmap (`treeFromDiff` t) (wholeTreeDiff t) +deciders t ts = fmap (`treeFromDiffs` t) (sequence (fmap (diff t) ts))
src/Overload/Example.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell, TypeFamilies, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -ddump-splices #-} module Overload.Example where import Data.Maybe @@ -20,3 +21,12 @@ print (f 1) print (f && True) print (fromMaybe 10 f) + +g1 :: (Int, Char) +g1 = undefined +g2 :: (Bool, ()) +g2 = undefined +g3 :: (Int, ()) +g3 = undefined + +overload "g" ['g1, 'g2, 'g3]
+ src/Overload/General.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +module Overload.General where + +import Data.Functor.Identity +import Control.Effects.State +import Control.Monad +import Data.List (foldl') + +import Overload.TypeTree + +type VariableMapping a b = [(a, TypeTree b)] + +trySetVar :: (MonadEffectState (VariableMapping a b) m, Eq a, Eq b) => a -> TypeTree b -> m Bool +trySetVar name typ = do + mapping <- getState + case lookup name mapping of + Just typ' | typ == typ' -> return True + | otherwise -> return False + Nothing -> do + setState ((name, typ) : mapping) + return True + +isMoreGeneralThan :: forall a b. (Eq a, Eq b) => TypeTree a -> TypeTree b -> Bool +isMoreGeneralThan t1 t2 = + runIdentity (handleStateT ([] :: VariableMapping a b) (isMoreGeneralThan' t1 t2)) + +isMoreGeneralThan' :: (MonadEffectState (VariableMapping a b) m, Eq a, Eq b) + => TypeTree a -> TypeTree b -> m Bool +isMoreGeneralThan' (Var n) t = trySetVar n t +isMoreGeneralThan' (Concrete n1) (Concrete n2) | n1 == n2 = return True +isMoreGeneralThan' (App t1 t2) (App t3 t4) = + (&&) <$> t1 `isMoreGeneralThan'` t3 <*> t2 `isMoreGeneralThan'` t4 +isMoreGeneralThan' _ _ = return False + +getEqualities :: forall a b. (Eq a, Eq b) => TypeTree a -> TypeTree b -> [(b, TypeTree a)] +getEqualities specific general = runIdentity $ handleStateT ([] :: VariableMapping b a) $ do + res <- general `isMoreGeneralThan'` specific + if res then getState + else error "Can't get equalities because the second type isn't more general than the first" + +minimize :: Eq a => [TypeTree a] -> [TypeTree a] +minimize [] = [] +minimize (t : ts) = foldl' minimizer [t] ts + where minimizer ms candidate = runIdentity $ handleStateT True $ do + ms' <- filterM (\m -> + if m `isMoreGeneralThan` candidate then setState False >> return True + else if candidate `isMoreGeneralThan` m then return False + else return True) ms + newMin <- getState + if newMin then return (candidate : ms') + else return ms'
+ src/Overload/Normal.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE ScopedTypeVariables, TypeApplications, FlexibleContexts, AllowAmbiguousTypes #-} +module Overload.Normal where + +import Control.Effects.State +import Data.Functor.Identity + +import Overload.TypeTree + +newtype Normal = Normal Int deriving (Eq, Ord) +instance Show Normal where + show (Normal n) = show n + +type FreshSource a = ([(a, Normal)], Normal) + +lookupName :: (MonadEffectState (FreshSource a) m, Eq a) => a -> m Normal +lookupName name = do + (table, Normal top) <- getState + case lookup name table of + Nothing -> do + setState ((name, Normal top) : table, Normal (top + 1)) + return (Normal top) + Just n -> return n + +freshVar :: forall a m. MonadEffectState (FreshSource a) m => m Normal +freshVar = do + (table, Normal top) :: FreshSource a <- getState + setState (table, Normal (top + 1)) + return (Normal top) + +normalizeTypeTree :: forall a. Eq a => TypeTree (Maybe a) -> TypeTree Normal +normalizeTypeTree = + runIdentity + . handleStateT (([], Normal 0) :: FreshSource a) + . traverse (maybe (freshVar @a) lookupName)
+ src/Overload/TypeTree.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +module Overload.TypeTree where + +import Language.Haskell.TH + +data TypeTree name = Var name | Concrete Type | App (TypeTree name) (TypeTree name) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +isDistinguishable :: Type -> Q Bool +isDistinguishable (AppT t1 _) = isDistinguishable t1 +isDistinguishable (ConT n) = do + info <- reify n + case info of + TyConI _ -> return True + PrimTyConI{} -> return True + TyVarI{} -> return True + _ -> return False +isDistinguishable ArrowT = return True +isDistinguishable (SigT t _) = isDistinguishable t +isDistinguishable (PromotedT _) = return True +isDistinguishable (ParensT t) = isDistinguishable t +isDistinguishable (TupleT _) = return True +isDistinguishable (UnboxedTupleT _) = return True +isDistinguishable ListT = return True +isDistinguishable (PromotedTupleT _) = return True +isDistinguishable PromotedNilT = return True +isDistinguishable PromotedConsT = return True +isDistinguishable (LitT _) = return True +isDistinguishable _ = return False + +typeToTypeTree :: (Type -> TypeTree a) -> (Name -> a) -> Type -> Q (TypeTree a) +typeToTypeTree nonDist f (AppT t1 t2) = do + con <- isDistinguishable t1 + if con then App <$> typeToTypeTree nonDist f t1 <*> typeToTypeTree nonDist f t2 + else return (nonDist (AppT t1 t2)) +typeToTypeTree _ f (VarT n) = return (Var (f n)) +typeToTypeTree nonDist f (InfixT t1 n t2) = typeToTypeTree nonDist f (AppT (AppT (ConT n) t1) t2) +typeToTypeTree nonDist f (SigT t _) = typeToTypeTree nonDist f t +typeToTypeTree _ _ t = return (Concrete t) + +typeTreeWithNames :: Show a => TypeTree a -> TypeTree Name +typeTreeWithNames = fmap (\a -> mkName ("t" ++ show a)) + +typeTreeToType :: TypeTree Name -> Type +typeTreeToType (Var n) = VarT n +typeTreeToType (Concrete n) = n +typeTreeToType (App t1 t2) = AppT (typeTreeToType t1) (typeTreeToType t2) + +showTypeTree :: Show a => TypeTree a -> String +showTypeTree = pprint . typeTreeToType . typeTreeWithNames