overloaded 0.1.3 → 0.2
raw patch · 10 files changed
+384/−47 lines, 10 filesdep +bindep +raldep ~vec
Dependencies added: bin, ral
Dependency ranges changed: vec
Files
- CHANGELOG.md +8/−0
- overloaded.cabal +8/−2
- src/Overloaded/Lists.hs +75/−16
- src/Overloaded/Lists/Bidi.hs +93/−0
- src/Overloaded/Numerals.hs +39/−6
- src/Overloaded/TypeNats.hs +11/−1
- test/Overloaded/Test/Lists.hs +54/−14
- test/Overloaded/Test/Lists/Bidi.hs +70/−0
- test/Overloaded/Test/Numerals.hs +16/−0
- test/Tests.hs +10/−8
CHANGELOG.md view
@@ -1,3 +1,11 @@+# 0.2++- Make infixr 5 cons+- Make Vec, NP and POP instances match more eagerly+- Add `Overloaded.Lists.Bidi`+- Add `Seq`, `Map` and `IntMap` `Cons` and `Nil` instances+- Add `bin` and `ral` instances+ # 0.1.3 - Add `Nil` and `Cons` `Set` and `IntSet` instanes
overloaded.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: overloaded-version: 0.1.3+version: 0.2 synopsis: Overloaded pragmas as a plugin description: Implement @Overloaded@ pragmas as a source plugin@@ -38,6 +38,7 @@ Overloaded.Chars Overloaded.If Overloaded.Lists+ Overloaded.Lists.Bidi Overloaded.Naturals Overloaded.Numerals Overloaded.Plugin@@ -56,13 +57,15 @@ -- other dependencies build-depends:+ , bin ^>=0.1 , fin ^>=0.1+ , ral ^>=0.1 , record-hasfield ^>=1.0 , sop-core ^>=0.5.0.0 , split ^>=0.2.3.3 , syb ^>=0.7.1 , symbols ^>=0.3.0.0- , vec ^>=0.1.1.1 || ^>=0.2+ , vec >=0.1.1.1 && <0.4 test-suite example default-language: Haskell2010@@ -141,6 +144,7 @@ Overloaded.Test.Labels Overloaded.Test.Labels.GenericLens Overloaded.Test.Lists+ Overloaded.Test.Lists.Bidi Overloaded.Test.Naturals Overloaded.Test.Numerals Overloaded.Test.RecordFields@@ -153,12 +157,14 @@ -- inherited dependencies build-depends: , base+ , bin , bytestring , containers , fin , optics-core , optics-hasfield , overloaded+ , ral , record-hasfield , sop-core , symbols
src/Overloaded/Lists.hs view
@@ -9,7 +9,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | Another way to desugar overloaded numeric literals. See 'FromNatural'.+-- | Another way to desugar overloaded list literals. See 'Nil' and 'Cons'. -- -- An explicit list expression, e.g. @[1, True]@ is desugared to --@@ -33,10 +33,19 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.SOP.NP (NP (..), POP (..)) -import qualified Data.IntSet as IS-import qualified Data.Set as S-import qualified Data.Type.Nat as N-import qualified Data.Vec.Lazy as Vec+import qualified Data.Bin as B+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Map as M+import qualified Data.RAList as RAL+import qualified Data.RAList.NonEmpty as NERAL+import qualified Data.RAVec as RAV+import qualified Data.RAVec.NonEmpty as NERAV+import qualified Data.Sequence as Seq+import qualified Data.Set as S+import qualified Data.Type.Bin as B+import qualified Data.Type.Nat as N+import qualified Data.Vec.Lazy as Vec ------------------------------------------------------------------------------- -- Classes@@ -54,7 +63,9 @@ class Cons x ys zs | zs -> x ys where cons :: x -> ys -> zs --- | @since 0.1.2+infixr 5 `cons`++-- | @since 0.1.3 fromList :: (Nil xs, Cons x xs xs) => [x] -> xs fromList = foldr cons nil @@ -65,32 +76,56 @@ instance Nil [a] where nil = [] -instance Cons a [a] [a] where+instance (a ~ b, b ~ c) => Cons a [b] [c] where cons = (:) -instance Cons a [a] (NonEmpty a) where+instance (a ~ b, b ~ c) => Cons a [b] (NonEmpty c) where cons = (:|) ------------------------------------------------------------------------------- -- containers ------------------------------------------------------------------------------- --- | @since 0.1.2+-- | @since 0.1.3 instance Nil (S.Set a) where nil = S.empty --- | @since 0.1.2-instance Ord a => Cons a (S.Set a) (S.Set a) where+-- | @since 0.1.3+instance (Ord a, a ~ b, b ~ c) => Cons a (S.Set b) (S.Set c) where cons = S.insert --- | @since 0.1.2+-- | @since 0.1.3 instance Nil IS.IntSet where nil = IS.empty --- | @since 0.1.2+-- | @since 0.1.3 instance Cons Int IS.IntSet IS.IntSet where cons = IS.insert +-- | @since 0.2+instance Nil (Seq.Seq a) where+ nil = Seq.empty++-- | @since 0.2+instance (a ~ b, b ~ c) => Cons a (Seq.Seq b) (Seq.Seq c) where+ cons = (Seq.<|)++-- | @since 0.2+instance Nil (M.Map k v) where+ nil = M.empty++-- | @since 0.2+instance (Ord k, k ~ k1, k ~ k2, v ~ v1, v ~ v2) => Cons (k, v) (M.Map k1 v1) (M.Map k2 v2) where+ cons ~(k, v) = M.insert k v++-- | @since 0.2+instance Nil (IM.IntMap v) where+ nil = IM.empty++-- | @since 0.2+instance (i ~ Int, a ~ b, b ~ c) => Cons (i, a) (IM.IntMap b) (IM.IntMap c) where+ cons ~(i, x) = IM.insert i x+ ------------------------------------------------------------------------------- -- vec -------------------------------------------------------------------------------@@ -98,7 +133,7 @@ instance n ~ 'N.Z => Nil (Vec.Vec n a) where nil = Vec.VNil -instance Cons a (Vec.Vec n a) (Vec.Vec ('N.S n) a) where+instance (a ~ b, b ~ c, m ~ 'N.S n) => Cons a (Vec.Vec n b) (Vec.Vec m c) where cons = (Vec.:::) -------------------------------------------------------------------------------@@ -108,11 +143,35 @@ instance xs ~ '[] => Nil (NP f xs) where nil = Nil -instance Cons (f x) (NP f xs) (NP f (x ': xs)) where+instance (f ~ g, g ~ h, xxs ~ (x ': xs)) => Cons (f x) (NP g xs) (NP h xxs) where cons = (:*) instance xs ~ '[] => Nil (POP f xs) where nil = POP Nil -instance Cons (NP f xs) (POP f xss) (POP f (xs ': xss)) where+instance (f ~ g, g ~ h, xsxss ~ (xs ': xss)) => Cons (NP f xs) (POP g xss) (POP h xsxss) where cons = coerce (cons :: NP f xs -> NP (NP f) xss -> NP (NP f) (xs ': xss))++-------------------------------------------------------------------------------+-- ral+-------------------------------------------------------------------------------++instance Nil (RAL.RAList a) where+ nil = RAL.empty++instance (a ~ b, a ~ c) => Cons a (RAL.RAList b) (RAL.RAList c) where+ cons = RAL.cons++instance (a ~ b, a ~ c) => Cons a (RAL.RAList b) (NERAL.NERAList c) where+ cons x RAL.Empty = NERAL.singleton x+ cons x (RAL.NonEmpty xs) = NERAL.cons x xs++instance b ~ 'B.BZ => Nil (RAV.RAVec b a) where+ nil = RAV.empty++instance (b ~ 'B.BP bb, bp ~ B.Pred bb, bb ~ B.Succ' bp) => Cons a (RAV.RAVec bp a) (RAV.RAVec b a) where+ cons = RAV.cons++instance (bp ~ B.Pred b, b ~ B.Succ' bp) => Cons a (RAV.RAVec bp a) (NERAV.NERAVec b a) where+ cons x RAV.Empty = NERAV.singleton x+ cons x (RAV.NonEmpty xs) = NERAV.cons x xs
+ src/Overloaded/Lists/Bidi.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Another way to desugar list literals.+--+-- An explicit list expression, e.g. @[1, True]@ is desugared to+--+-- @+-- cons 1 (cons True nil)+-- @+--+-- This desugaring uses bidirectional functional dependencies to+-- make `cons` infer more. The trade-off is that we can have strictly+-- less instances.+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS_GHC -fplugin=Overloaded+-- -fplugin-opt=Overloaded:Lists=Overloaded.Lists.Bidi.nil=Overloaded.Lists.Bidi.cons+-- @+--+module Overloaded.Lists.Bidi (+ nil,+ Cons (..),+ Uni.fromList,+ ) where++import Data.SOP.NP (NP (..), POP (..))++import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import qualified Data.Sequence as Seq+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Type.Nat as N+import qualified Data.Vec.Lazy as Vec++import qualified Overloaded.Lists as Uni++-------------------------------------------------------------------------------+-- Classes+-------------------------------------------------------------------------------++nil :: Uni.Nil a => a+nil = Uni.nil+{-# INLINE nil #-}++-- | Bidirectional class for Cons ':'.+--+-- @since 0.2+class Uni.Cons x ys zs => Cons x ys zs | zs -> x ys, x ys -> zs where+ cons :: x -> ys -> zs+ cons = Uni.cons++infixr 5 `cons`++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++instance (a ~ b, b ~ c) => Cons a [b] [c]++-------------------------------------------------------------------------------+-- containers+-------------------------------------------------------------------------------++instance (Ord a, a ~ b, b ~ c) => Cons a (S.Set a) (S.Set a)+instance Cons Int IS.IntSet IS.IntSet+instance (a ~ b, b ~ c) => Cons a (Seq.Seq b) (Seq.Seq c)+instance (Ord k, k ~ k1, k ~ k2, v ~ v1, v ~ v2) => Cons (k, v) (M.Map k1 v1) (M.Map k2 v2)+instance (i ~ Int, a ~ b, b ~ c) => Cons (i, a) (IM.IntMap b) (IM.IntMap c)++-------------------------------------------------------------------------------+-- vec+-------------------------------------------------------------------------------++instance (a ~ b, b ~ c, m ~ 'N.S n) => Cons a (Vec.Vec n b) (Vec.Vec m c)++-------------------------------------------------------------------------------+-- sop-core+-------------------------------------------------------------------------------++instance (f ~ g, g ~ h, xxs ~ (x ': xs)) => Cons (f x) (NP g xs) (NP h xxs)+instance (f ~ g, g ~ h, xsxss ~ (xs ': xss)) => Cons (NP f xs) (POP g xss) (POP h xsxss)
src/Overloaded/Numerals.hs view
@@ -16,6 +16,8 @@ defaultFromNumeral, ) where +import Data.Bin.Pos (Pos (..))+import Data.BinP.PosP (PosP (..)) import Data.Fin (Fin (..)) import Data.Proxy (Proxy (..)) import Data.Word (Word16, Word32, Word64, Word8)@@ -24,7 +26,11 @@ import GHC.TypeNats (type (<=?), KnownNat, Nat, natVal) import Numeric.Natural (Natural) -import qualified Data.Type.Nat as N+import qualified Data.Bin as B+import qualified Data.BinP.PosP as PP+import qualified Data.Type.Bin as B+import qualified Data.Type.BinP as BP+import qualified Data.Type.Nat as N -- | Another way to desugar numerals. --@@ -99,11 +105,13 @@ instance KnownNat n => FromNumeral n N.Nat where fromNumeral = defaultFromNumeral @n -type family IsLess (n :: N.Nat) (m :: N.Nat) (p :: Nat) (q :: Nat) :: Constraint where- IsLess 'N.Z ('N.S m) p q = ()- IsLess ('N.S n) ('N.S m) p q = IsLess n m p q- IsLess ('N.S n) 'N.Z p q = TypeError ('ShowType p ':<>: 'Text " is not less than " ':<>: 'ShowType q)+type family IsLess (p :: Nat) (q :: Nat) :: Constraint where+ IsLess p q = IsLess' (q <=? p) p q +type family IsLess' (b :: Bool) (p :: Nat) (q :: Nat) :: Constraint where+ IsLess' 'False p q = ()+ IsLess' 'True p q = TypeError ('ShowType p ':<>: 'Text " is not less than " ':<>: 'ShowType q)+ class FinFromNumeral (n :: N.Nat) (m :: N.Nat) where finFromNumeral :: Proxy n -> Fin m @@ -113,5 +121,30 @@ instance FinFromNumeral n m => FinFromNumeral ('N.S n) ('N.S m) where finFromNumeral _ = FS (finFromNumeral (Proxy :: Proxy n)) -instance (FinFromNumeral (N.FromGHC n) m, IsLess (N.FromGHC n) m n (N.ToGHC m)) => FromNumeral n (Fin m) where+instance (FinFromNumeral (N.FromGHC n) m, IsLess n (N.ToGHC m)) => FromNumeral n (Fin m) where fromNumeral = finFromNumeral (Proxy :: Proxy (N.FromGHC n))++-------------------------------------------------------------------------------+-- bin+-------------------------------------------------------------------------------++instance KnownNat n => FromNumeral n B.Bin where+ fromNumeral = defaultFromNumeral @n++instance (KnownNat n, (1 <=? n) ~ 'True) => FromNumeral n B.BinP where+ fromNumeral = defaultFromNumeral @n++class PosFromNumeral (n :: N.Nat) (b :: B.BinP) where+ posFromNumeral:: Proxy n -> PosP b++instance B.SBinPI b => PosFromNumeral 'N.Z b where+ posFromNumeral _ = PP.top++instance (B.SBinPI bp, PosFromNumeral n bp, B.Pred b ~ 'B.BP bp, BP.Succ bp ~ b) => PosFromNumeral ('N.S n) b where+ posFromNumeral _ = PP.pop (posFromNumeral (Proxy :: Proxy n))++instance (PosFromNumeral (N.FromGHC n) b, IsLess n (BP.ToGHC b)) => FromNumeral n (PosP b) where+ fromNumeral = posFromNumeral (Proxy :: Proxy (N.FromGHC n))++instance (PosFromNumeral (N.FromGHC n) b, IsLess n (BP.ToGHC b)) => FromNumeral n (Pos ('B.BP b)) where+ fromNumeral = Pos (posFromNumeral (Proxy :: Proxy (N.FromGHC n)))
src/Overloaded/TypeNats.hs view
@@ -6,7 +6,11 @@ import GHC.TypeNats (Nat) -import qualified Data.Type.Nat as N+import qualified Data.Bin as B+import qualified Data.BinP as BP+import qualified Data.Type.Bin as B+import qualified Data.Type.BinP as BP+import qualified Data.Type.Nat as N -- | A way to overload type level 'Nat's. --@@ -30,3 +34,9 @@ instance FromNatC N.Nat where type FromNat n = N.FromGHC n++instance FromNatC B.Bin where+ type FromNat n = B.FromGHC n++instance FromNatC BP.BinP where+ type FromNat n = BP.FromGHC n
test/Overloaded/Test/Lists.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Lists #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS -fplugin=Overloaded+ -fplugin-opt=Overloaded:Lists+ #-} module Overloaded.Test.Lists where import Data.List.NonEmpty (NonEmpty (..))@@ -11,9 +16,11 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) -import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Type.Nat as N+import qualified Data.Map as Map+import qualified Data.RAVec as RAV+import qualified Data.RAVec.NonEmpty as NERAV+import qualified Data.Set as Set+import qualified Data.Type.Nat as N import Overloaded.Lists @@ -38,6 +45,12 @@ -- -- res @?= 6 + , testCase "RAVec" $+ RAV.toList ['x','y','z'] @?= "xyz"++ , testCase "RAVec.NonEmpty" $+ NERAV.toNonEmpty ['x','y','z'] @?= ('x' :| "yz")+ , testCase "NP" $ do let np :: NP I '[Int, Bool, String] np = [I 1, I True, I "YES"]@@ -58,7 +71,7 @@ , testCase "Map pairs" $ do let m :: Map.Map Int Char- m = unN [(1, 'x'), (3, 'y'), (2, 'z')]+ m = [(1, 'x'), (3, 'y'), (2, 'z')] m @?= Map.fromList [(1,'x'),(2,'z'),(3,'y')] @@ -72,9 +85,39 @@ ] ---------------------------------------------------------------------------------- Map inline+-- Inference ------------------------------------------------------------------------------- +_vecTest00 :: Vec 'N.Z Int+_vecTest00 = nil++-- check bidi-inference+_vecTest01 = as2 @Vec $ 1 `cons` 2 `cons` _vecTest00++-- GHC doesn't infer this type, though it could?+-- On the other hand+--+-- inferenceTestStr = fromString "foo"+--+-- doesn't work out in the source files either: MonomorphismRestriction+-- In GHCi things work, +--+-- @+-- *Overloaded> :t True `cons` 'a' `cons` nil+-- True `cons` 'a' `cons` nil+-- :: (Cons Bool ys1 zs, Cons Char ys2 ys1, Nil ys2) => zs+-- @+--+inferenceTest :: (Nil xs, Cons x xs ys, Cons y ys zs, Num x, Num y) => zs+inferenceTest = [1, 2]++_inferenceList = as1 @[] inferenceTest+_inferenceVec = as2 @Vec inferenceTest++-------------------------------------------------------------------------------+-- Map inline: weird thing to do+-------------------------------------------------------------------------------+ newtype M k v = M { unM :: Map.Map k v } deriving (Eq, Show) @@ -90,14 +133,11 @@ cons k (M' km) = M (km k) ---------------------------------------------------------------------------------- Map pairs+-- As ------------------------------------------------------------------------------- -newtype N k v = N { unN :: Map.Map k v }- deriving (Eq, Show)--instance Nil (N k v) where- nil = N Map.empty+as1 :: tycon a -> tycon a+as1 = id -instance Ord k => Cons (k,v) (N k v) (N k v) where- cons (k,v) (N m) = N (Map.insert k v m)+as2 :: tycon a b -> tycon a b+as2 = id
+ test/Overloaded/Test/Lists/Bidi.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -fplugin=Overloaded+ -fplugin-opt=Overloaded:Lists=Overloaded.Lists.Bidi.nil=Overloaded.Lists.Bidi.cons+ #-}+module Overloaded.Test.Lists.Bidi where++import Data.List.NonEmpty (NonEmpty (..))+import Data.SOP.BasicFunctors (I (..))+import Data.SOP.NP (NP (..), POP (..))+import Data.Vec.Lazy (Vec (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Type.Nat as N++import Overloaded.Lists.Bidi++int :: Int+int = 1++tests :: TestTree+tests = testGroup "Lists"+ [ testCase "[]" $+ [1,2,3] @?= ([1,2,3] :: [Int])++ , testCase "Vec" $+ [1,2,3] @?= int ::: 2 ::: 3 ::: VNil++-- Patterns not supported+-- , testCase "Vec pattern-match" $do+-- let res = case [1,2,3] :: Vec N.Nat3 Int of+-- [x,y,z] -> x + y + z+--+-- res @?= 6++ , testCase "NP" $ do+ let np :: NP I '[Int, Bool, String]+ np = [I 1, I True, I "YES"]++ np @?= I 1 :* I True :* I "YES" :* Nil++ , testCase "POP" $ do+ let pop :: POP I '[ '[Int, Bool], '[String] ]+ pop = [[I 0, I False], [I "NO"]]++ pop @?= POP ((I 0 :* I False :* Nil) :* (I "NO" :* Nil) :* Nil)++ , testCase "Set" $ do+ let s :: Set.Set Char+ s = ['f', 'o', 'o']++ s @?= Set.fromList ['o', 'f']++ s @?= fromList ['o', 'f']+ ]++-------------------------------------------------------------------------------+-- Inference+-------------------------------------------------------------------------------++_vecTest00 :: Vec 'N.Z Int+_vecTest00 = nil++-- check bidi-inference+_vecTest01 = 1 `cons` 2 `cons` _vecTest00
test/Overloaded/Test/Numerals.hs view
@@ -2,10 +2,14 @@ {-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Numerals #-} module Overloaded.Test.Numerals where +import Data.Bin (Bin, BinP) import Data.Fin (Fin (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) +import qualified Data.Bin as B+import qualified Data.BinP as BP+import qualified Data.Type.Bin as B import qualified Data.Type.Nat as N tests :: TestTree@@ -21,4 +25,16 @@ 2 -> True -- works, because there is @Num (Fin n)@ instance _ -> False res @?= True++ , testCase "Data.Bin" $ do+ let b :: Bin+ b = 0++ b @?= B.fromNatural 0++ , testCase "Data.BinP" $ do+ let b :: BinP+ b = 1++ b @?= BP.fromNatural 1 ]
test/Tests.hs view
@@ -2,14 +2,15 @@ import Test.Tasty (defaultMain, testGroup) -import qualified Overloaded.Test.Chars as Chr-import qualified Overloaded.Test.If as Iff-import qualified Overloaded.Test.Labels as Lbl-import qualified Overloaded.Test.Lists as Lst-import qualified Overloaded.Test.Naturals as Nat-import qualified Overloaded.Test.Numerals as Num-import qualified Overloaded.Test.Strings as Str-import qualified Overloaded.Test.Symbols as Sym+import qualified Overloaded.Test.Chars as Chr+import qualified Overloaded.Test.If as Iff+import qualified Overloaded.Test.Labels as Lbl+import qualified Overloaded.Test.Lists as Lst+import qualified Overloaded.Test.Lists.Bidi as Lst.Bidi+import qualified Overloaded.Test.Naturals as Nat+import qualified Overloaded.Test.Numerals as Num+import qualified Overloaded.Test.Strings as Str+import qualified Overloaded.Test.Symbols as Sym import qualified Overloaded.Test.Labels.GenericLens as GL @@ -19,6 +20,7 @@ , Iff.tests , Lbl.tests , Lst.tests+ , Lst.Bidi.tests , Nat.tests , Num.tests , Str.tests