overloaded 0.2.1 → 0.3
raw patch · 26 files changed
+1009/−168 lines, 26 filesdep +profunctorsdep +semigroupoidsdep +splitmixdep ~basedep ~bindep ~constraints
Dependencies added: profunctors, semigroupoids, splitmix, template-haskell, th-compat
Dependency ranges changed: base, bin, constraints, fin, ghc, lens, ral, tasty, vec
Files
- CHANGELOG.md +7/−0
- example/AD.hs +78/−38
- example/LocalDo.hs +7/−5
- example/VectorSpace.hs +21/−5
- overloaded.cabal +32/−16
- src/GHC/Compat/All.hs +50/−2
- src/GHC/Compat/Expr.hs +17/−3
- src/Overloaded.hs +8/−0
- src/Overloaded/Categories.hs +262/−17
- src/Overloaded/CodeLabels.hs +20/−0
- src/Overloaded/CodeStrings.hs +37/−0
- src/Overloaded/Plugin.hs +250/−50
- src/Overloaded/Plugin/Categories.hs +15/−2
- src/Overloaded/Plugin/Diagnostics.hs +9/−2
- src/Overloaded/Plugin/HasField.hs +12/−5
- src/Overloaded/Plugin/LocalDo.hs +25/−3
- src/Overloaded/Plugin/Names.hs +29/−0
- src/Overloaded/Plugin/Rewrite.hs +6/−0
- test/Overloaded/Test/Categories.hs +10/−9
- test/Overloaded/Test/CodeLabels.hs +21/−0
- test/Overloaded/Test/CodeLabels/String.hs +16/−0
- test/Overloaded/Test/CodeStrings.hs +23/−0
- test/Overloaded/Test/RebindableApplications.hs +25/−0
- test/Regexp/Type.hs +2/−0
- test/STLC.hs +10/−0
- test/Tests.hs +17/−11
CHANGELOG.md view
@@ -1,3 +1,10 @@+# 0.3++- Add `Overloaded:RebindableApplications`+- Add `Overloaded:CodeLabels` and `Overloaded:CodeStrings`+ (they don't work well though due how Typed Template Haskell is type-checked).+- Change class hierarcy in `Overloaded.Category`+ # 0.2.1 - Add `Overloaded:Categories`, which makes `Arrows` notation desugar to
example/AD.hs view
@@ -7,17 +7,19 @@ {-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Categories #-} module Main where -import Numeric (showFFloat)+import Control.Monad (when)+import Data.Word (Word64)+import Numeric (showFFloat)+import System.Environment (getArgs)+import Data.List (intercalate) import qualified Control.Category-import qualified Numeric.LinearAlgebra as LA+import qualified Numeric.LinearAlgebra as LA+import qualified System.Random.SplitMix as SM import Overloaded.Categories import VectorSpace -evalL :: (HasDim a, HasDim b) => L a b -> LA.Matrix Double-evalL (L f) = toRawMatrix (f LI)- -- | A Function which computes value and derivative at the point. newtype AD a b = AD (a -> (b, L a b)) @@ -136,6 +138,40 @@ gamma = 0.1 -------------------------------------------------------------------------------+-- Random+-------------------------------------------------------------------------------++randomDoubles :: Word64 -> [Double]+randomDoubles seed = go (SM.mkSMGen seed) where+ go g = let (d, g') = SM.nextDouble g in d : go g'++-------------------------------------------------------------------------------+-- Dot+-------------------------------------------------------------------------------++class VectorSpace' a where+ sumN :: AD a Double+ multN :: AD (a, a) a++instance (VectorSpace' a, VectorSpace' b) => VectorSpace' (a, b) where+ sumN = proc (x, y) -> do+ x' <- sumN -< x+ y' <- sumN -< y+ plus -< (x', y')++ multN = proc ((x1, x2), (y1, y2)) -> do+ z1 <- multN -< (x1, y1)+ z2 <- multN -< (x2, y2)+ identity -< (z1, z2)++instance VectorSpace' Double where+ sumN = identity+ multN = mult++dot :: VectorSpace' a => AD (a, a) Double+dot = sumN %% multN++------------------------------------------------------------------------------- -- ML stuff ------------------------------------------------------------------------------- @@ -149,39 +185,25 @@ let y = 1 / (1 + exp (- x)) in (x, linear (y * (1 - y))) +-- | weights for 2x1 connection. Two weights and bias.+type Weights' = ((Double, Double), Double) --- no biases-type Weights = ((((Double, Double), (Double, Double)), ((Double, Double), (Double, Double))), Double)+-- | Two internal neurons, and final output+type Weights = ((Weights', Weights'), Weights') startWeights :: Weights-startWeights = ((((0.1, 0.2), (0.3, 0.4)), ((0.5, 0.6), (0.7, 0.8))), 0.9)------- @--- x ----> u ---,--- X output--- y ----> v ---^--- @-network :: AD (Weights, (Double, Double)) Double-network = proc (((((w11,w12),(w21,w22)),((b1, b2), (z1, z2))), bend), (x, y)) -> do- x1 <- mult -< (x, w11)- y1 <- mult -< (y, w12)- u0 <- plus -< (x1, y1)- u1 <- plus -< (u0, b1)- u2 <- tanhAD -< u1-- x2 <- mult -< (x, w21)- y2 <- mult -< (y, w22)- v0 <- plus -< (x2, y2)- v1 <- plus -< (v0, b2)- v2 <- tanhAD -< v1+startWeights = fromVector $ randomDoubles 1337 - u <- mult -< (u2, z1)- v <- mult -< (v2, z2)+neuron :: AD (Weights', (Double, Double)) Double+neuron = proc ((ws, bias), i) -> do+ o <- dot -< (ws, i)+ tanhAD %% plus -< (o, bias) - output' <- plus -< (u, v)- output <- plus -< (bend, output')- tanhAD -< output+network :: AD (Weights, (Double, Double)) Double+network = proc (((w1, w2), w3), xy) -> do+ u <- neuron -< (w1, xy)+ v <- neuron -< (w2, xy)+ neuron -< (w3, (u, v)) networkError :: AD Weights Double networkError = proc ws -> do@@ -191,10 +213,7 @@ s3 <- ex 1 0 1 -< ws s4 <- ex 0 1 1 -< ws - tmp1 <- plus -< (s1, s2)- tmp2 <- plus -< (s3, s4)- plus -< (tmp1, tmp2)-+ sumN -< ((s1,s2), (s3, s4)) where ex :: Double -> Double -> Double -> AD Weights Double ex x y z = proc ws -> do@@ -203,7 +222,7 @@ e1 <- konst z -< () a1 <- network -< (ws, (x1, y1)) r1 <- minus -< (e1, a1)- mult -< (r1, r1)+ mult -< (r1, r1) train :: Weights train = gradDesc networkError startWeights !! 500@@ -226,7 +245,28 @@ putStrLn $ "Error = " ++ show (fst $ evaluateAD networkError ws) let example xy = putStrLn $ "eval " ++ show xy ++ " = " ++ showFFloat (Just 2) (fst $ evaluateAD network (ws, xy)) ""+ example (0, 0) example (0, 1) example (1, 0) example (1, 1)++ args <- getArgs+ when ("plot" `elem` args) $ do+ putStrLn "Outputting plot data: datafile.dat"++ let n = 20 :: Int+ let points = [ fromIntegral x / fromIntegral n | x <- [0..n] ] :: [Double]++ let output :: String+ output = unlines+ [ intercalate "\t"+ [ show x+ , show y+ , show (fst (evaluateAD network (ws, (x, y))))+ ]+ | x <- points+ , y <- points+ ]++ writeFile "datafile.dat" output
example/LocalDo.hs view
@@ -10,10 +10,12 @@ {-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Do #-} module Main (main) where -import Data.Kind (Type)+import Control.Applicative ((<|>))+import Data.Kind (Type)+import Data.Maybe (fromMaybe)+import System.Timeout (timeout)+ import Overloaded-import System.Timeout (timeout)-import Data.Maybe (fromMaybe) -- Idea / example by Vladislav Zavialov (int-inded) from: -- https://github.com/ghc-proposals/ghc-proposals/pull/216#issuecomment-614771416@@ -21,8 +23,8 @@ main :: IO () main = do putStrLn "Enter string, you have 10 seconds..."- str <- fromMaybe "timed out..." <$> timeout 10000000 getLine- let customIO :: forall (method :: DoMethod) ty. CustomIO method ty => ty + str <- fromMaybe "timed out..." <$> timeout 10000000 (getLine <|> return "")+ let customIO :: forall (method :: DoMethod) ty. CustomIO method ty => ty customIO = makeCustomIO @method @ty str customIO.do putStrLn "Hello"
example/VectorSpace.hs view
@@ -14,6 +14,7 @@ LinMap (..), HasDim(Dim, dimDict), toRawMatrix,+ evalL, L (..), linear, VectorSpace (..),@@ -70,6 +71,10 @@ proj2 = LV LZ LI fanout = LH +instance CategoryWith0 LinMap where+ type Initial LinMap = ()+ initial = LZ+ instance CocartesianCategory LinMap where type Coproduct LinMap = (,) inl = LH LI LZ@@ -92,13 +97,16 @@ lfst LI = LV LI LZ lsnd :: LinMap a (b, c) -> LinMap a c-lsnd (LH _ g) = g-lsnd (LA f g) = LA (lsnd f) (lsnd g)+lsnd (LH _ g) = g+lsnd (LA f g) = LA (lsnd f) (lsnd g) lsnd (LK k f) = LK k (lsnd f)-lsnd (LV f g) = LV (lsnd f) (lsnd g)-lsnd LZ = LZ-lsnd LI = LV LZ LI+lsnd (LV f g) = LV (lsnd f) (lsnd g)+lsnd LZ = LZ+lsnd LI = LV LZ LI +linitial :: LinMap r () -> LinMap r a+linitial _ = LZ+ linear :: Double -> L a a linear k = L $ LK k @@ -127,6 +135,11 @@ fanout (L f) (L g) = L $ \x -> LH (f x) (g x) +instance CategoryWith0 L where+ type Initial L = ()++ initial = L linitial+ -- Is this correct? instance CocartesianCategory L where type Coproduct L = (,)@@ -181,6 +194,9 @@ toRawMatrix (LV f g) = go splitPair f g where go :: (Dict (HasDim x), Dict (HasDim y)) -> LinMap x b -> LinMap y b -> L.Matrix Double go (Dict, Dict) f' g' = toRawMatrix f' L.=== toRawMatrix g'++evalL :: (HasDim a, HasDim b) => L a b -> L.Matrix Double+evalL (L f) = toRawMatrix (f LI) -- toStaticMatrix :: forall a b. (HasDim a, HasDim b) => LinMap a b -> LS.L (Dim a) (Dim b) -- toStaticMatrix LZ =
overloaded.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: overloaded-version: 0.2.1+version: 0.3 synopsis: Overloaded pragmas as a plugin description: Implement @Overloaded@ pragmas as a source plugin@@ -23,7 +23,7 @@ maintainer: Oleg Grenrus <oleg.grenrus@iki.fi> category: Plugin extra-source-files: CHANGELOG.md-tested-with: GHC ==8.6.5 || ==8.8.3 || ==8.10.1+tested-with: GHC ==8.6.5 || ==8.8.3 || ==8.10.4 || ==9.0.1 source-repository head type: git@@ -37,6 +37,8 @@ Overloaded Overloaded.Categories Overloaded.Chars+ Overloaded.CodeLabels+ Overloaded.CodeStrings Overloaded.Do Overloaded.If Overloaded.Lists@@ -62,25 +64,29 @@ -- GHC boot dependencies build-depends:- , base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0- , bytestring ^>=0.10.8.2- , containers ^>=0.6.0.1- , ghc ^>=8.6 || ^>=8.8 || ^>=8.10- , text ^>=1.2.3.0- , time ^>=1.8.0.2 || ^>=1.9.3+ , base ^>=4.12.0.0 || ^>=4.13.0.0 || ^>=4.14.0.0 || ^>=4.15.0.0+ , bytestring ^>=0.10.8.2+ , containers ^>=0.6.0.1+ , ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0+ , template-haskell+ , text ^>=1.2.3.0+ , time ^>=1.8.0.2 || ^>=1.9.3 -- other dependencies build-depends: , assoc ^>=1.0.1- , bin ^>=0.1- , fin ^>=0.1- , ral ^>=0.1+ , bin ^>=0.1.1+ , fin ^>=0.2+ , profunctors ^>=5.6+ , ral ^>=0.2 , record-hasfield ^>=1.0+ , semigroupoids ^>=5.3.4 , 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.4+ , th-compat ^>=0.1.1+ , vec ^>=0.4 test-suite example default-language: Haskell2010@@ -153,7 +159,7 @@ -- test dependencies build-depends: , boring ^>=0.1.3- , constraints >=0.11.2 && <0.13+ , constraints ^>=0.13 , HUnit ^>=1.6.0.0 , tasty , tasty-hunit@@ -177,10 +183,14 @@ other-modules: VectorSpace build-depends: , base- , constraints ^>=0.12+ , constraints ^>=0.13 , hmatrix ^>=0.20.0.0 , overloaded+ , splitmix ^>=0.1 + if impl(ghc >=9.0)+ buildable: False+ library optics-hasfield default-language: Haskell2010 hs-source-dirs: optics-hasfield@@ -200,6 +210,9 @@ IxMonad Overloaded.Test.Categories Overloaded.Test.Chars+ Overloaded.Test.CodeLabels+ Overloaded.Test.CodeLabels.String+ Overloaded.Test.CodeStrings Overloaded.Test.Do Overloaded.Test.If Overloaded.Test.Labels@@ -208,6 +221,7 @@ Overloaded.Test.Lists.Bidi Overloaded.Test.Naturals Overloaded.Test.Numerals+ Overloaded.Test.RebindableApplications Overloaded.Test.RecordFields Overloaded.Test.Strings Overloaded.Test.Symbols@@ -231,16 +245,18 @@ , record-hasfield , sop-core , symbols+ , template-haskell , text+ , th-compat , time , vec -- test dependencies build-depends: , generic-lens-lite ^>=0.1- , lens ^>=4.18 || ^>=4.19.1+ , lens ^>=5 , QuickCheck ^>=2.14 , singleton-bool ^>=0.1.5- , tasty ^>=1.2.3+ , tasty ^>=1.4.1 , tasty-hunit ^>=0.10.0.2 , tasty-quickcheck ^>=0.10.1.1
src/GHC/Compat/All.hs view
@@ -3,8 +3,45 @@ module X, -- * Extras mkFunTy,+mkLocalMultId, ) where +#if MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Types as X+import GHC.Core as X+import GHC.Core.Class as X+import GHC.Core.Coercion as X+import GHC.Core.DataCon as X+import GHC.Core.FamInstEnv as X+import GHC.Core.Make as X+import GHC.Core.Predicate as X+import GHC.Core.TyCon as X+import GHC.Core.Type as X+import GHC.Driver.Finder as X+import GHC.Driver.Session as X+import GHC.Driver.Types as X+import GHC.Hs as X+import GHC.Iface.Env as X+import GHC.Tc.Instance.Family as X+import GHC.Tc.Types as X+import GHC.Tc.Types.Constraint as X+import GHC.Tc.Types.Evidence as X+import GHC.Tc.Utils.Env as X+import GHC.Tc.Utils.Instantiate as X+import GHC.Tc.Utils.Monad as X+import GHC.Tc.Utils.TcMType as X+import GHC.Types.Basic as X+import GHC.Types.Id as X+import GHC.Types.Name as X+import GHC.Types.Name.Reader as X+import GHC.Types.SrcLoc as X+import GHC.Unit.Module.Name as X+import GHC.Utils.Error as X+import GHC.Utils.Outputable as X++import qualified GHC.Core.TyCo.Rep as GHC++#else #if MIN_VERSION_ghc(8,10,0) import Constraint as X import Predicate as X@@ -30,15 +67,17 @@ import Name as X import Outputable as X import RdrName as X+import SrcLoc as X import TcEnv as X import TcEvidence as X import TcMType as X import TcRnMonad as X-import TyCon as X import TyCoRep as X hiding (mkFunTy)+import TyCon as X import TysWiredIn as X import qualified TyCoRep as GHC+#endif ------------------------------------------------------------------------------- -- Compat functions@@ -46,8 +85,17 @@ mkFunTy :: X.Type -> X.Type -> X.Type mkFunTy =-#if MIN_VERSION_ghc(8,10,0)+#if MIN_VERSION_ghc(9,0,0)+ GHC.mkFunTy X.VisArg X.Many+#elif MIN_VERSION_ghc(8,10,0) GHC.mkFunTy X.VisArg #else GHC.mkFunTy+#endif++mkLocalMultId :: X.Name -> X.Type -> X.Id+#if MIN_VERSION_ghc(9,0,0)+mkLocalMultId n t = X.mkLocalId n X.Many t+#else+mkLocalMultId n t = X.mkLocalId n t #endif
src/GHC/Compat/Expr.hs view
@@ -26,6 +26,9 @@ -- * Patterns LPat, Pat (..),+ -- * Splices+ HsSplice (..),+ SpliceDecoration (..), -- * Proc commands HsCmdTop (..), HsCmd (..),@@ -50,7 +53,9 @@ #endif -- * Statements HsGroup,- -- * Reader phase+ HsModule,+ -- * phases+ GhcPs, GhcRn, -- * SourceSpan Located,@@ -74,14 +79,23 @@ import HsSyn #endif -#if MIN_VERSION_ghc(8,8,0)+#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.Basic (PromotionFlag (..))+#elif MIN_VERSION_ghc(8,8,0) import BasicTypes (PromotionFlag (..)) #endif -import Data.List (foldl')+#if MIN_VERSION_ghc(9,0,0)+import GHC.Types.SrcLoc+ (GenLocated (..), Located, RealSrcSpan, SrcSpan (..), noSrcSpan,+ srcSpanEndCol, srcSpanEndLine, srcSpanStartCol, srcSpanStartLine)+#else import SrcLoc (GenLocated (..), Located, RealSrcSpan, SrcSpan (..), noSrcSpan, srcSpanEndCol, srcSpanEndLine, srcSpanStartCol, srcSpanStartLine)+#endif++import Data.List (foldl') import qualified GHC.Compat.All as GHC
src/Overloaded.hs view
@@ -29,6 +29,12 @@ -- * Overloaded:Labels -- | See "GHC.OverloadedLabels" for 'GHC.OverloadedLabels.fromLabel'. + -- * Overloaded:CodeLabels+ IsCodeLabel (..),++ -- * Overloaded:CodeStrings+ IsCodeString (..),+ -- * Overloaded:TypeNats FromNatC (..), @@ -53,6 +59,8 @@ import Overloaded.Categories import Overloaded.Chars+import Overloaded.CodeLabels+import Overloaded.CodeStrings import Overloaded.Do import Overloaded.If import Overloaded.Lists
src/Overloaded/Categories.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-} -- | Overloaded Categories, desugar @Arrow@ into classes in this module. -- -- == Enabled with@@ -16,9 +17,9 @@ -- The 'arr' combinator is used for plumbing. We should desugar to proper -- type-classes: ----- * 'CartesianCategory', not 'Arrow'--- * 'CocartesianCategory', not 'ArrowChoice' (implementation relies on 'BicartesianCategory')--- * 'CCC', not 'ArrowApply' (not implemented yet)+-- * 'CartesianCategory', not 'A.Arrow'+-- * 'CocartesianCategory', not 'A.ArrowChoice' (implementation relies on 'BicartesianCategory')+-- * 'CCC', not 'A.ArrowApply' (not implemented yet) -- -- == Examples --@@ -55,7 +56,7 @@ -- -- @proc@ notation is nicer than writing de Bruijn indices. ----- This is very similar idea to Conal Elliott's [Compiling to Categories](http://conal.net/papers/compiling-to-categories/) work. +-- This is very similar idea to Conal Elliott's [Compiling to Categories](http://conal.net/papers/compiling-to-categories/) work. -- This approach is syntactically more heavy, but works in more correct -- stage of compiler, before actual desugarer. --@@ -75,7 +76,7 @@ -- evaluateAD (AD f) x xs = let (y, f') = f x in (y, fmap f' xs) -- @ ----- which would allow to calculuate function value and +-- which would allow to calculuate function value and -- derivatives in given directions. Then we can define -- simple quadratic function: --@@ -108,23 +109,43 @@ -- be definable! -- module Overloaded.Categories (+ -- * Category C.Category, identity, (%%),- CategoryWith1 (..),+ -- * Monoidial+ SemigroupalCategory (..),+ defaultAssoc, defaultUnassoc,+ MonoidalCategory (..),+ defaultLunit, defaultRunit, defaultUnrunit, defaultUnlunit,+ CommutativeCategory (..),+ defaultSwap,+ -- * Product and Terminal CartesianCategory (..),+ CategoryWith1 (..),+ -- * Coproduct and initial+ CategoryWith0 (..), CocartesianCategory (..),+ -- * Bicartesian BicartesianCategory (..),+ -- * Closed cartesian category CCC (..),+ -- * Generalized element GeneralizedElement (..),+ -- * WrappedArrow+ WrappedArrow (..), ) where +import qualified Control.Arrow as A import qualified Control.Category as C-import Data.Kind (Type) -#ifdef __HADDOCK__-import Control.Arrow-#endif+import Control.Applicative (liftA2)+import Control.Arrow (Kleisli (..))+import Data.Functor.Contravariant (Op (..))+import Data.Kind (Type)+import Data.Profunctor (Star (..))+import Data.Semigroupoid.Dual (Dual (..))+import Data.Void (Void, absurd) ------------------------------------------------------------------------------- -- Category@@ -145,22 +166,62 @@ -- Monoidal ------------------------------------------------------------------------------- --- TODO+class C.Category cat => SemigroupalCategory (cat :: k -> k -> Type) where+ type Tensor cat :: k -> k -> k + assoc :: cat (Tensor cat (Tensor cat a b) c)+ (Tensor cat a (Tensor cat b c))++ unassoc :: cat (Tensor cat a (Tensor cat b c))+ (Tensor cat (Tensor cat a b) c)++defaultAssoc :: (CartesianCategory cat, Tensor cat ~ Product cat) => cat (Tensor cat (Tensor cat a b) c) (Tensor cat a (Tensor cat b c))+defaultAssoc = fanout (proj1 %% proj1) (fanout (proj2 %% proj1) proj2)++defaultUnassoc :: (CartesianCategory cat, Tensor cat ~ Product cat) => cat (Tensor cat a (Tensor cat b c)) (Tensor cat (Tensor cat a b) c)+defaultUnassoc = fanout (fanout proj1 (proj1 %% proj2)) (proj2 %% proj2)++class SemigroupalCategory cat => MonoidalCategory (cat :: k -> k -> Type) where+ type Unit cat :: k++ lunit :: cat (Tensor cat (Unit cat) a) a+ runit :: cat (Tensor cat a (Unit cat)) a++ unlunit :: cat a (Tensor cat (Unit cat) a)+ unrunit :: cat a (Tensor cat a (Unit cat))++defaultLunit :: (CartesianCategory cat, Tensor cat ~ Product cat) => cat (Tensor cat (Unit cat) a) a+defaultLunit = proj2++defaultRunit :: (CartesianCategory cat, Tensor cat ~ Product cat) => cat (Tensor cat a (Unit cat)) a+defaultRunit = proj1++defaultUnlunit :: (CategoryWith1 cat, Tensor cat ~ Product cat, Unit cat ~ Terminal cat) => cat a (Tensor cat (Unit cat) a)+defaultUnlunit = fanout terminal identity++defaultUnrunit :: (CategoryWith1 cat, Tensor cat ~ Product cat, Unit cat ~ Terminal cat) => cat a (Tensor cat a (Unit cat))+defaultUnrunit = fanout identity terminal++class SemigroupalCategory cat => CommutativeCategory cat where+ swap :: cat (Tensor cat a b) (Tensor cat b a)++defaultSwap :: (CartesianCategory cat, Tensor cat ~ Product cat) => cat (Tensor cat a b) (Tensor cat b a)+defaultSwap = fanout proj2 proj1+ ------------------------------------------------------------------------------- -- Product ------------------------------------------------------------------------------- -- | Category with terminal object.-class C.Category cat => CategoryWith1 (cat :: k -> k -> Type) where+class CartesianCategory cat => CategoryWith1 (cat :: k -> k -> Type) where type Terminal cat :: k- + terminal :: cat a (Terminal cat) -- | Cartesian category is a monoidal category -- where monoidal product is the categorical product. ---class CategoryWith1 cat => CartesianCategory (cat :: k -> k -> Type) where+class C.Category cat => CartesianCategory (cat :: k -> k -> Type) where type Product cat :: k -> k -> k proj1 :: cat (Product cat a b) a@@ -181,10 +242,28 @@ proj2 = snd fanout f g x = (f x , g x) +instance CategoryWith1 Op where+ type Terminal Op = Void++ terminal = Op absurd++instance CartesianCategory Op where+ type Product Op = Either++ proj1 = Op inl+ proj2 = Op inr+ fanout (Op f) (Op g) = Op (fanin f g)+ ------------------------------------------------------------------------------- -- Coproduct ------------------------------------------------------------------------------- +-- | Category with initial object.+class CocartesianCategory cat => CategoryWith0 (cat :: k -> k -> Type) where+ type Initial cat :: k++ initial :: cat (Initial cat) a+ -- | Cocartesian category is a monoidal category -- where monoidal product is the categorical coproduct. --@@ -197,6 +276,11 @@ -- | @'fanin' f g@ is written as \([f, g]\) in category theory literature. fanin :: cat a c -> cat b c -> cat (Coproduct cat a b) c +instance CategoryWith0 (->) where+ type Initial (->) = Void++ initial = absurd+ instance CocartesianCategory (->) where type Coproduct (->) = Either @@ -204,6 +288,18 @@ inr = Right fanin = either +instance CategoryWith0 Op where+ type Initial Op = ()++ initial = Op (const ())++instance CocartesianCategory Op where+ type Coproduct Op = (,)++ inl = Op proj1+ inr = Op proj2+ fanin (Op f) (Op g) = Op (fanout f g)+ -- | Bicartesian category is category which is -- both cartesian and cocartesian. --@@ -217,6 +313,34 @@ distr (Right y, z) = Right (y, z) -------------------------------------------------------------------------------+-- Dual+-------------------------------------------------------------------------------++instance CategoryWith1 cat => CategoryWith0 (Dual cat) where+ type Initial (Dual cat) = Terminal cat+ initial = Dual terminal++instance CategoryWith0 cat => CategoryWith1 (Dual cat) where+ type Terminal (Dual cat) = Initial cat+ terminal = Dual initial++instance CartesianCategory cat => CocartesianCategory (Dual cat) where+ type Coproduct (Dual cat) = Product cat++ inl = Dual proj1+ inr = Dual proj2++ fanin (Dual f) (Dual g) = Dual (fanout f g)++instance CocartesianCategory cat => CartesianCategory (Dual cat) where+ type Product (Dual cat) = Coproduct cat++ proj1 = Dual inl+ proj2 = Dual inr++ fanout (Dual f) (Dual g) = Dual (fanin f g)++------------------------------------------------------------------------------- -- Exponential ------------------------------------------------------------------------------- @@ -249,3 +373,124 @@ type Object (->) a = a konst = const++-------------------------------------------------------------------------------+-- Star+-------------------------------------------------------------------------------++instance Monad m => CartesianCategory (Star m) where+ type Product (Star m) = (,)++ proj1 = Star (pure . proj1)+ proj2 = Star (pure . proj2)++ fanout (Star f) (Star g) = Star $ \a -> liftA2 (,) (f a) (g a)++instance Monad m => CategoryWith1 (Star m) where+ type Terminal (Star m) = ()++ terminal = Star (pure . terminal)++instance Monad m => CocartesianCategory (Star m) where+ type Coproduct (Star m) = Either++ inl = Star (pure . inl)+ inr = Star (pure . inr)++ fanin (Star f) (Star g) = Star (fanin f g)++instance Monad m => CategoryWith0 (Star m) where+ type Initial (Star m) = Void++ initial = Star (pure . initial)++instance Monad m => BicartesianCategory (Star m) where+ distr = Star (pure . distr)++instance Monad m => CCC (Star m) where+ type Exponential (Star m) = Star m++ eval = Star $ uncurry runStar+ transpose (Star f) = Star $ \a -> pure $ Star $ \b -> f (a, b)++-------------------------------------------------------------------------------+-- Kleisli+-------------------------------------------------------------------------------++instance Monad m => CartesianCategory (Kleisli m) where+ type Product (Kleisli m) = (,)++ proj1 = Kleisli (pure . proj1)+ proj2 = Kleisli (pure . proj2)++ fanout (Kleisli f) (Kleisli g) = Kleisli $ \a -> liftA2 (,) (f a) (g a)++instance Monad m => CategoryWith1 (Kleisli m) where+ type Terminal (Kleisli m) = ()++ terminal = Kleisli (pure . terminal)++instance Monad m => CocartesianCategory (Kleisli m) where+ type Coproduct (Kleisli m) = Either++ inl = Kleisli (pure . inl)+ inr = Kleisli (pure . inr)++ fanin (Kleisli f) (Kleisli g) = Kleisli (fanin f g)++instance Monad m => CategoryWith0 (Kleisli m) where+ type Initial (Kleisli m) = Void++ initial = Kleisli (pure . initial)++instance Monad m => BicartesianCategory (Kleisli m) where+ distr = Kleisli (pure . distr)++instance Monad m => CCC (Kleisli m) where+ type Exponential (Kleisli m) = Kleisli m++ eval = Kleisli $ uncurry runKleisli+ transpose (Kleisli f) = Kleisli $ \a -> pure $ Kleisli $ \b -> f (a, b)++-------------------------------------------------------------------------------+-- WrappedArrow+-------------------------------------------------------------------------------++newtype WrappedArrow arr a b = WrapArrow { unwrapArrow :: arr a b }++instance C.Category arr => C.Category (WrappedArrow arr) where+ id = WrapArrow identity+ WrapArrow f . WrapArrow g = WrapArrow (f %% g)++instance A.Arrow arr => CategoryWith1 (WrappedArrow arr) where+ type Terminal (WrappedArrow arr) = ()+ terminal = WrapArrow (A.arr terminal)++instance A.Arrow arr => CartesianCategory (WrappedArrow arr) where+ type Product (WrappedArrow arr) = (,)+ proj1 = WrapArrow (A.arr proj1)+ proj2 = WrapArrow (A.arr proj2)+ fanout (WrapArrow f) (WrapArrow g) = WrapArrow (f A.&&& g)++instance A.ArrowChoice arr => CategoryWith0 (WrappedArrow arr) where+ type Initial (WrappedArrow arr) = Void+ initial = WrapArrow (A.arr absurd)++instance A.ArrowChoice arr => CocartesianCategory (WrappedArrow arr) where+ type Coproduct (WrappedArrow arr) = Either+ inl = WrapArrow (A.arr inl)+ inr = WrapArrow (A.arr inr)+ fanin (WrapArrow f) (WrapArrow g) = WrapArrow (f A.||| g)++instance A.ArrowChoice arr => BicartesianCategory (WrappedArrow arr) where+ distr = WrapArrow (A.arr distr)++instance A.ArrowApply arr => CCC (WrappedArrow arr) where+ type Exponential (WrappedArrow arr) = arr++ eval = WrapArrow A.app+ transpose = error "ArrowApply @(WrappedArrow arr) is not implemented"++instance A.Arrow arr => GeneralizedElement (WrappedArrow arr) where+ type Object (WrappedArrow arr) a = a+ konst = WrapArrow . A.arr . const
+ src/Overloaded/CodeLabels.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Overloaded.CodeLabels where++import GHC.TypeLits (Symbol)+import Language.Haskell.TH.Syntax.Compat (SpliceQ)++-- | Class for auto-spliced labels+--+-- The labels @#lbl@ is desugared into @$$(codeFromlabel \@"lbl")@ splice.+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:CodeLabels #-}+-- @+--+-- This feature is not very usable, see https://gitlab.haskell.org/ghc/ghc/-/issues/18211+class IsCodeLabel (sym :: Symbol) a where+ codeFromLabel :: SpliceQ a
+ src/Overloaded/CodeStrings.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module Overloaded.CodeStrings where++import Control.Monad (when)+import Data.Char (ord)+import Data.Word (Word8)+import Language.Haskell.TH (appE)+import Language.Haskell.TH.Syntax (lift, reportWarning)+import Language.Haskell.TH.Syntax.Compat (SpliceQ, unsafeSpliceCoerce)++import qualified Data.ByteString as BS++-- | Class for auto-spliced string literals+--+-- The string literals @"beer"@ is desugared into @$$(codeFromString \@"beer")@ splice.+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:CodeLabels #-}+-- @+--+-- This feature is not very usable, see https://gitlab.haskell.org/ghc/ghc/-/issues/18211+class IsCodeString a where+ codeFromString :: String -> SpliceQ a++instance a ~ Char => IsCodeString [a] where+ codeFromString = unsafeSpliceCoerce . lift++instance IsCodeString BS.ByteString where+ codeFromString str = unsafeSpliceCoerce $ do+ when (any (> '\255') str ) $+ reportWarning "Splicing non-ASCII ByteString"++ let octets :: [Word8]+ octets = map (fromIntegral . ord) str++ [| BS.pack |] `appE` lift octets
src/Overloaded/Plugin.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Overloaded plugin, which makes magic possible. module Overloaded.Plugin (plugin) where +import Control.Exception (throwIO) import Control.Monad (foldM, when) import Control.Monad.IO.Class (MonadIO (..)) import Data.List (intercalate)@@ -14,7 +16,12 @@ -- GHC stuff import qualified GHC.Compat.All as GHC import GHC.Compat.Expr++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Plugins as Plugins+#else import qualified GhcPlugins as Plugins+#endif import Overloaded.Plugin.Categories import Overloaded.Plugin.Diagnostics@@ -67,6 +74,9 @@ -- * @TypeNats@ and @TypeSymbols@ desugar type-level literals into @'Overloaded.TypeNats.FromNat'@ and @'Overloaded.TypeSymbols.FromTypeSymbol'@ respectively -- * @Do@ desugar in /Local Do/ fashion. See examples. -- * @Categories@ change @Arrows@ desugaring to use /"correct"/ category classes.+-- * @CodeLabels@ desugars @OverloadedLabels@ into Typed Template Haskell splices+-- * @CodeStrings@ desugars string literals into Typed Template Haskell splices+-- * @RebindableApplication@ changes how juxtaposition is interpreted -- -- == Known limitations --@@ -136,9 +146,26 @@ -- 'traverse' f (Branch l r) = [| Branch ('traverse' f l) ('traverse' f r) |] -- @ --+-- == RebindableApplication+--+-- Converts all @f x@ applications into @(f $ x)@ with whatever @$@+-- is in scope.+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:RebindableApplication #-}+--+-- let f = pure ((+) :: Int -> Int -> Int)+-- x = Just 1+-- y = Just 2+-- +-- z = let ($) = ('<*>') in f x y+-- in z+-- @+-- plugin :: Plugins.Plugin plugin = Plugins.defaultPlugin- { Plugins.renamedResultAction = pluginImpl+ { Plugins.renamedResultAction = renamedAction+ , Plugins.parsedResultAction = parsedAction , Plugins.tcPlugin = enabled tcPlugin , Plugins.pluginRecompile = Plugins.purePlugin }@@ -149,12 +176,16 @@ where args = concatMap (splitOn ":") args' -pluginImpl+-------------------------------------------------------------------------------+-- Renamer+-------------------------------------------------------------------------------++renamedAction :: [Plugins.CommandLineOption] -> GHC.TcGblEnv -> HsGroup GhcRn -> GHC.TcM (GHC.TcGblEnv, HsGroup GhcRn)-pluginImpl args' env gr = do+renamedAction args' env gr = do dflags <- GHC.getDynFlags topEnv <- GHC.getTopEnv @@ -170,18 +201,22 @@ transformNoOp _ = NoRewrite trStr <- case optStrings of- NoStr -> return transformNoOp- Str Nothing -> return $ transformStrings names- Sym Nothing -> return $ transformSymbols names- Str (Just vn) -> do+ NoStr -> return transformNoOp+ Str Nothing -> return $ transformStrings names+ Sym Nothing -> return $ transformSymbols names+ CodeStr Nothing -> return $ transformCodeStrings names+ Str (Just vn) -> do n <- lookupVarName dflags topEnv vn return $ transformStrings $ names { fromStringName = n }- Sym (Just vn) -> do+ Sym (Just vn) -> do n <- lookupVarName dflags topEnv vn return $ transformSymbols $ names { fromSymbolName = n }+ CodeStr (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformSymbols $ names { codeFromStringName = n } trNum <- case optNumerals of- NoNum -> return transformNoOp+ NoNum -> return transformNoOp IsNum Nothing -> return $ transformNumerals names IsNat Nothing -> return $ transformNaturals names IsNum (Just vn) -> do@@ -214,11 +249,15 @@ return $ transformIf $ names { ifteName = n } trLabel <- case optLabels of- Off -> return transformNoOp- On Nothing -> return $ transformLabels names- On (Just vn) -> do+ NoLabel -> return transformNoOp+ Label Nothing -> return $ transformLabels names+ CodeLabel Nothing -> return $ transformCodeLabels names+ Label (Just vn) -> do n <- lookupVarName dflags topEnv vn return $ transformLabels $ names { fromLabelName = n }+ CodeLabel (Just vn) -> do+ n <- lookupVarName dflags topEnv vn+ return $ transformCodeLabels $ names { codeFromLabelName = n } trBrackets <- case optIdiomBrackets of False -> return transformNoOp@@ -256,58 +295,107 @@ n <- lookupTypeName dflags topEnv vn return $ transformTypeSymbols $ names { fromTypeSymbolName = n } - let tr = trStr <> trNum <> trChr <> trLists <> trIf <> trLabel <> trBrackets <> trDo <> trCategories <> trUnit+ let tr = mconcat+ [ trStr+ , trNum+ , trChr+ , trLists+ , trIf+ , trLabel+ , trBrackets+ , trDo+ , trCategories+ , trUnit+ ] let trT = trTypeNats <> trTypeSymbols gr' <- transformType dflags trT gr- gr'' <- transform dflags tr gr'+ gr'' <- transformRn dflags tr gr' return (env, gr'') where args = concatMap (splitOn ":") args' -------------------------------------------------------------------------------+-- Parsed Action+-------------------------------------------------------------------------------++parsedAction+ :: [Plugins.CommandLineOption]+ -> Plugins.ModSummary+ -> Plugins.HsParsedModule+ -> Plugins.Hsc Plugins.HsParsedModule+parsedAction args _modSum pm = do+ let hsmodule = Plugins.hpm_module pm++ dflags <- GHC.getDynFlags++ debug $ show args+ debug $ GHC.showPpr dflags hsmodule++ let names = defaultRdrNames+ _opts@Options {..} <- parseArgs dflags args++ let transformNoOp :: a -> Rewrite a+ transformNoOp _ = NoRewrite++ trRebindApp <- case optRebindApp of+ Off -> return transformNoOp+ On Nothing -> return $ transformRebindableApplication names+ On (Just rn) -> do+ let n = mkRdrName rn+ return $ transformRebindableApplication $ names { dollarName = n }++ hsmodule' <- transformPs dflags trRebindApp hsmodule+ let pm' = pm { Plugins.hpm_module = hsmodule' }++ return pm'++------------------------------------------------------------------------------- -- Args parsing ------------------------------------------------------------------------------- parseArgs :: forall m. MonadIO m => GHC.DynFlags -> [String] -> m Options parseArgs dflags = foldM go0 defaultOptions where+ ambWarn :: String -> String -> m ()+ ambWarn x y = warn dflags noSrcSpan $+ GHC.text ("Overloaded:" ++ x ++ " and Overloaded:" ++ y ++ " enabled")+ GHC.$$+ GHC.text ("picking Overloaded:" ++ y)+ go0 opts arg = do (arg', vns) <- elaborateArg arg go opts arg' vns go opts "Strings" vns = do- when (isSym $ optStrings opts) $ warn dflags noSrcSpan $- GHC.text "Overloaded:Strings and Overloaded:Symbols enabled"- GHC.$$- GHC.text "picking Overloaded:Strings"+ when (isSym $ optStrings opts) $ ambWarn "Symbols" "Strings"+ when (isCodeStr $ optStrings opts) $ ambWarn "CodeStrings" "Strings" mvn <- oneName "Strings" vns return $ opts { optStrings = Str mvn } go opts "Symbols" vns = do- when (isStr $ optStrings opts) $ warn dflags noSrcSpan $- GHC.text "Overloaded:Strings and Overloaded:Symbols enabled"- GHC.$$- GHC.text "picking Overloaded:Symbols"+ when (isStr $ optStrings opts) $ ambWarn "Strings" "Symbols"+ when (isCodeStr $ optStrings opts) $ ambWarn "CodeStrings" "Symbols" mvn <- oneName "Symbols" vns return $ opts { optStrings = Sym mvn } + go opts "CodeStrings" vns = do+ when (isStr $ optStrings opts) $ ambWarn "Strings" "CodeStrings"+ when (isSym $ optStrings opts) $ ambWarn "Symbols" "CodeStrings"++ mvn <- oneName "CodeStrings" vns+ return $ opts { optStrings = CodeStr mvn }+ go opts "Numerals" vns = do- when (isNat $ optNumerals opts) $ warn dflags noSrcSpan $- GHC.text "Overloaded:Numerals and Overloaded:Naturals enabled"- GHC.$$- GHC.text "picking Overloaded:Numerals"+ when (isNat $ optNumerals opts) $ ambWarn "Naturals" "Numerals" mvn <- oneName "Numerals" vns return $ opts { optNumerals = IsNum mvn } go opts "Naturals" vns = do- when (isNum $ optNumerals opts) $ warn dflags noSrcSpan $- GHC.text "Overloaded:Numerals and Overloaded:Naturals enabled"- GHC.$$- GHC.text "picking Overloaded:Naturals"+ when (isNum $ optNumerals opts) $ ambWarn "Numerals" "Naturals" mvn <- oneName "Naturals" vns return $ opts { optNumerals = IsNat mvn }@@ -325,8 +413,15 @@ mvn <- oneName "Unit" vns return $ opts { optUnit = On mvn } go opts "Labels" vns = do- mvn <- oneName "Symbols" vns- return $ opts { optLabels = On mvn }+ when (isCodeLabel $ optLabels opts) $ ambWarn "CodeLabels" "Labels"++ mvn <- oneName "Labels" vns+ return $ opts { optLabels = Label mvn }+ go opts "CodeLabels" vns = do+ when (isLabel $ optLabels opts) $ ambWarn "Labels" "CodeLabels"++ mvn <- oneName "CodeLabels" vns+ return $ opts { optLabels = CodeLabel mvn } go opts "TypeNats" vns = do mvn <- oneName "TypeNats" vns return $ opts { optTypeNats = On mvn }@@ -342,6 +437,9 @@ go opts "Categories" vns = do mvn <- oneName "Categories" vns return $ opts { optCategories = On $ fmap (\(VN x _) -> x) mvn }+ go opts "RebindableApplication" vns = do+ mrn <- oneName "RebindableApplication" vns+ return $ opts { optRebindApp = On mrn } go opts s _ = do warn dflags noSrcSpan $ GHC.text $ "Unknown Overloaded option " ++ show s@@ -384,7 +482,7 @@ , optChars :: OnOff VarName , optLists :: OnOff (V2 VarName) , optIf :: OnOff VarName- , optLabels :: OnOff VarName+ , optLabels :: LabelOpt , optUnit :: OnOff VarName , optTypeNats :: OnOff VarName , optTypeSymbols :: OnOff VarName@@ -392,6 +490,7 @@ , optIdiomBrackets :: Bool , optDo :: Bool , optCategories :: OnOff String -- module name+ , optRebindApp :: OnOff VarName } deriving (Eq, Show) @@ -402,7 +501,7 @@ , optChars = Off , optLists = Off , optIf = Off- , optLabels = Off+ , optLabels = NoLabel , optTypeNats = Off , optTypeSymbols = Off , optUnit = Off@@ -410,12 +509,14 @@ , optIdiomBrackets = False , optDo = False , optCategories = Off+ , optRebindApp = Off } data StrSym = NoStr | Str (Maybe VarName) | Sym (Maybe VarName)+ | CodeStr (Maybe VarName) deriving (Eq, Show) isSym :: StrSym -> Bool@@ -426,6 +527,10 @@ isStr (Str _) = True isStr _ = False +isCodeStr :: StrSym -> Bool+isCodeStr (CodeStr _) = True+isCodeStr _ = False+ data NumNat = NoNum | IsNum (Maybe VarName)@@ -434,12 +539,26 @@ isNum :: NumNat -> Bool isNum (IsNum _) = True-isNum _ = False+isNum _ = False isNat :: NumNat -> Bool isNat (IsNat _) = True isNat _ = False +data LabelOpt+ = NoLabel+ | Label (Maybe VarName)+ | CodeLabel (Maybe VarName)+ deriving (Eq, Show)++isLabel :: LabelOpt -> Bool+isLabel (Label _) = True+isLabel _ = False++isCodeLabel :: LabelOpt -> Bool+isCodeLabel (CodeLabel _) = True+isCodeLabel _ = False+ data OnOff a = Off | On (Maybe a)@@ -468,6 +587,17 @@ transformSymbols _ _ = NoRewrite -------------------------------------------------------------------------------+-- OverloadedCodeStrings+-------------------------------------------------------------------------------++transformCodeStrings :: Names -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)+transformCodeStrings Names {..} e@(L l (HsLit _ (HsString _ _fs))) = do+ let inner = hsApps l (hsVar l codeFromStringName) [e]+ WithName $ \n -> Rewrite $ L l $ HsSpliceE noExtField $ HsTypedSplice noExtField hasParens n inner++transformCodeStrings _ _ = NoRewrite++------------------------------------------------------------------------------- -- OverloadedNumerals ------------------------------------------------------------------------------- @@ -524,7 +654,11 @@ ------------------------------------------------------------------------------- transformIf :: Names -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)+#if MIN_VERSION_ghc(9,0,0)+transformIf Names {..} (L l (HsIf _ co th el)) = Rewrite val4 where+#else transformIf Names {..} (L l (HsIf _ _ co th el)) = Rewrite val4 where+#endif val4 = L l $ HsApp noExtField val3 el val3 = L l $ HsApp noExtField val2 th val2 = L l $ HsApp noExtField val1 co@@ -544,6 +678,26 @@ transformLabels _ _ = NoRewrite -------------------------------------------------------------------------------+-- OverloadedCodeLabels+-------------------------------------------------------------------------------++hasParens :: SpliceDecoration+#if MIN_VERSION_ghc(9,0,0)+hasParens = DollarSplice+#else+hasParens = HasParens+#endif++transformCodeLabels :: Names -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)+transformCodeLabels Names {..} (L l (HsOverLabel _ Nothing fs)) = do+ let name' = hsVar l codeFromLabelName+ let inner = hsTyApp l name' (HsTyLit noExtField (HsStrTy GHC.NoSourceText fs))+ -- Rewrite $ L l $ HsRnBracketOut noExtField (ExpBr noExtField inner) []+ WithName $ \n -> Rewrite $ L l $ HsSpliceE noExtField $ HsTypedSplice noExtField hasParens n inner++transformCodeLabels _ _ = NoRewrite++------------------------------------------------------------------------------- -- OverloadedUnit ------------------------------------------------------------------------------- @@ -576,25 +730,68 @@ transformTypeSymbols _ _ = NoRewrite -------------------------------------------------------------------------------+-- RebindableApplication+-------------------------------------------------------------------------------++transformRebindableApplication :: RdrNames -> LHsExpr GhcPs -> Rewrite (LHsExpr GhcPs)+transformRebindableApplication RdrNames {..} (L l (HsApp _ f@(L fl _) x@(L xl _)))+ = Rewrite+ $ L l $ HsPar noExtField+ $ L l $ OpApp noExtField f (L l' (HsVar noExtField (L l' dollarName))) x+ where+ l' = GHC.mkSrcSpan (GHC.srcSpanEnd fl) (GHC.srcSpanStart xl)+transformRebindableApplication _ _ = NoRewrite++------------------------------------------------------------------------------- -- Transform ------------------------------------------------------------------------------- -transform+transformRn :: GHC.DynFlags -> (LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)) -> HsGroup GhcRn -> GHC.TcM (HsGroup GhcRn)-transform dflags f = SYB.everywhereM (SYB.mkM transform') where+transformRn dflags f = SYB.everywhereM (SYB.mkM transform') where transform' :: LHsExpr GhcRn -> GHC.TcM (LHsExpr GhcRn)+ transform' e@(L l _) = do+ -- liftIO $ GHC.putLogMsg _dflags GHC.NoReason GHC.SevWarning _l (GHC.defaultErrStyle _dflags) $+ -- GHC.text "Expr" GHC.<+> GHC.ppr e GHC.<+> GHC.text (SYB.gshow e)+ go (f e)+ where+ go NoRewrite = return e+ go (Rewrite e') = return e'+ go (Error err) = do+ liftIO $ err dflags+ fail "Error in Overloaded plugin"+ go (WithName kont) = do+ n <- GHC.newNameAt (GHC.mkVarOcc "olSplice") l+ go (kont n)++transformPs+ :: GHC.DynFlags+ -> (LHsExpr GhcPs -> Rewrite (LHsExpr GhcPs))+#if MIN_VERSION_ghc(9,0,0)+ -> Located HsModule+ -> Plugins.Hsc (Located HsModule)+#else+ -> Located (HsModule GhcPs)+ -> Plugins.Hsc (Located (HsModule GhcPs))+#endif+transformPs dflags f = SYB.everywhereM (SYB.mkM transform') where+ transform' :: LHsExpr GhcPs -> Plugins.Hsc (LHsExpr GhcPs) transform' e@(L _l _) = do -- liftIO $ GHC.putLogMsg _dflags GHC.NoReason GHC.SevWarning _l (GHC.defaultErrStyle _dflags) $ -- GHC.text "Expr" GHC.<+> GHC.ppr e GHC.<+> GHC.text (SYB.gshow e)- case f e of- Rewrite e' -> return e'- NoRewrite -> return e- Error err -> do- liftIO $ err dflags- fail "Error in Overloaded plugin"+ go (f e)+ where+ go NoRewrite = return e+ go (Rewrite e') = return e'+ go (Error err) = do+ liftIO $ err dflags+ -- Hsc doesn't have MonadFail instance+ liftIO $ throwIO $ userError "Error in Overloaded plugin"+ go (WithName _kont) = do+ liftIO $ throwIO $ userError "Error in Overloaded plugin: WithName in Ps transform" transformType :: GHC.DynFlags@@ -603,10 +800,13 @@ -> GHC.TcM (HsGroup GhcRn) transformType dflags f = SYB.everywhereM (SYB.mkM transform') where transform' :: LHsType GhcRn -> GHC.TcM (LHsType GhcRn)- transform' e = do- case f e of- Rewrite e' -> return e'- NoRewrite -> return e- Error err -> do- liftIO $ err dflags- fail "Error in Overloaded plugin"+ transform' e@(L l _) = go (f e)+ where+ go NoRewrite = return e+ go (Rewrite e') = return e'+ go (Error err) = do+ liftIO $ err dflags+ fail "Error in Overloaded plugin"+ go (WithName kont) = do+ n <- GHC.newNameAt (GHC.mkVarOcc "olSplice") l+ go (kont n)
src/Overloaded/Plugin/Categories.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-}@@ -17,7 +17,12 @@ import qualified Data.Map.Strict as Map import qualified GHC.Compat.All as GHC import GHC.Compat.Expr++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Plugins as Plugins+#else import qualified GhcPlugins as Plugins+#endif import Overloaded.Plugin.Diagnostics import Overloaded.Plugin.Names@@ -132,7 +137,11 @@ return $ Last (Left morp') expr' parseCmd names ctx (L _ (HsCmdCase _ expr matchGroup)) = case mg_alts matchGroup of-#if MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,1)+#if MIN_VERSION_ghc(9,0,1)+ L _ [ L _ Match { m_pats = [L _ (ConPat _ (L _ acon) aargs)], m_grhss = abody' }+ , L _ Match { m_pats = [L _ (ConPat _ (L _ bcon) bargs)], m_grhss = bbody' }+ ]+#elif MIN_VERSION_ghc(8,8,0) && !MIN_VERSION_ghc(8,10,1) L _ [ L _ Match { m_pats = [XPat (L _ (ConPatIn (L _ acon) aargs))], m_grhss = abody' } , L _ Match { m_pats = [XPat (L _ (ConPatIn (L _ bcon) bargs))], m_grhss = bbody' } ]@@ -197,7 +206,11 @@ -> SrcSpan -> [CmdLStmt GhcRn] -> Rewrite (Continuation (LHsExpr GhcRn) (Var b a))+#if MIN_VERSION_ghc(9,0,1)+parseStmts names ctx _ (L l (BindStmt _ pat body) : next) = do+#else parseStmts names ctx _ (L l (BindStmt _ pat body _ _) : next) = do+#endif SomePattern pat' <- parsePat pat cont1 <- parseCmd names ctx body cont2 <- parseStmts names (combineMaps ctx pat') l next
src/Overloaded/Plugin/Diagnostics.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Overloaded.Plugin.Diagnostics where import Control.Monad.IO.Class (MonadIO (..))@@ -9,13 +10,19 @@ -- Doesn't really belong here ------------------------------------------------------------------------------- +#if MIN_VERSION_ghc(9,0,0)+#define ERR_STYLE+#else+#define ERR_STYLE (GHC.defaultErrStyle dflags)+#endif+ putError :: MonadIO m => GHC.DynFlags -> SrcSpan -> GHC.SDoc -> m () putError dflags l doc =- liftIO $ GHC.putLogMsg dflags GHC.NoReason GHC.SevError l (GHC.defaultErrStyle dflags) doc+ liftIO $ GHC.putLogMsg dflags GHC.NoReason GHC.SevError l ERR_STYLE doc warn :: MonadIO m => GHC.DynFlags -> SrcSpan -> GHC.SDoc -> m () warn dflags l doc =- liftIO $ GHC.putLogMsg dflags GHC.NoReason GHC.SevWarning l (GHC.defaultErrStyle dflags) doc+ liftIO $ GHC.putLogMsg dflags GHC.NoReason GHC.SevWarning l ERR_STYLE doc debug :: MonadIO m => String -> m () -- debug = liftIO . putStrLn
src/Overloaded/Plugin/HasField.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} module Overloaded.Plugin.HasField where @@ -7,8 +8,14 @@ import qualified GHC.Compat.All as GHC import GHC.Compat.Expr-import qualified TcPluginM as Plugins +#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Tc.Plugin as Plugins+#else+import qualified TcPluginM as Plugins+#endif++import Overloaded.Plugin.Diagnostics import Overloaded.Plugin.Names import Overloaded.Plugin.V @@ -31,7 +38,7 @@ GHC.Found _ md -> Plugins.tcLookupClass =<< Plugins.lookupOrig md (GHC.mkTcOcc "HasField") _ -> do dflags <- GHC.unsafeTcPluginTcM GHC.getDynFlags- Plugins.tcPluginIO $ GHC.putLogMsg dflags GHC.NoReason GHC.SevError noSrcSpan (GHC.defaultErrStyle dflags) $+ Plugins.tcPluginIO $ putError dflags noSrcSpan $ GHC.text "Cannot find module" GHC.<+> GHC.ppr ghcRecordsCompatMN fail "panic!" @@ -82,7 +89,7 @@ let t' = s' bName <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc "b")- let bBndr = GHC.mkLocalId bName $ xs !! idx+ let bBndr = GHC.mkLocalMultId bName $ xs !! idx -- (\b -> DC b x1 x2, x0) let rhs = GHC.mkConApp (GHC.tupleDataCon GHC.Boxed 2)@@ -111,7 +118,7 @@ -- \s -> case s of DC x0 x1 x2 -> (\b -> DC b x1 x2, x0) sName <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc "s")- let sBndr = GHC.mkLocalId sName s'+ let sBndr = GHC.mkLocalMultId sName s' let expr = GHC.mkCoreLams [sBndr] $ GHC.Case (GHC.Var sBndr) sBndr caseType [caseBranch] let evterm = makeEvidence4 hasPolyFieldCls expr tys @@ -139,7 +146,7 @@ makeVar :: String -> GHC.Type -> GHC.TcPluginM GHC.Var makeVar n ty = do name <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc n)- return (GHC.mkLocalId name ty)+ return (GHC.mkLocalMultId name ty) ------------------------------------------------------------------------------- -- Simple Ct operations
src/Overloaded/Plugin/LocalDo.hs view
@@ -1,21 +1,39 @@+{-# LANGUAGE CPP #-} module Overloaded.Plugin.LocalDo where import qualified Data.Generics as SYB import qualified GHC.Compat.All as GHC import GHC.Compat.Expr++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Plugins as Plugins+#else import qualified GhcPlugins as Plugins+#endif import Overloaded.Plugin.Diagnostics import Overloaded.Plugin.Names import Overloaded.Plugin.Rewrite +#if MIN_VERSION_ghc(9,0,0)+#define _bufspan _+#else+#define _bufspan+#endif+ transformDo :: Names -> LHsExpr GhcRn -> Rewrite (LHsExpr GhcRn)-transformDo names (L l (OpApp _ (L (RealSrcSpan l1) (HsVar _ (L _ doName)))- (L (RealSrcSpan l2) (HsVar _ (L _ compName')))- (L (RealSrcSpan l3) (HsDo _ DoExpr (L _ stmts)))))+transformDo names (L l (OpApp _ (L (RealSrcSpan l1 _bufspan) (HsVar _ (L _ doName)))+ (L (RealSrcSpan l2 _bufspan) (HsVar _ (L _ compName')))+ (L (RealSrcSpan l3 _bufspan)+#if MIN_VERSION_ghc(9,0,0)+ (HsDo _ (DoExpr Nothing) (L _ stmts))+#else+ (HsDo _ DoExpr (L _ stmts))+#endif+ ))) | spanNextTo l1 l2 , spanNextTo l2 l3 , compName' == composeName names@@ -27,7 +45,11 @@ transformDo' :: Names -> GHC.Name -> SrcSpan -> [ExprLStmt GhcRn] -> Either (GHC.DynFlags -> IO ()) (LHsExpr GhcRn) transformDo' _names _doName l [] = Left $ \dflags -> putError dflags l $ GHC.text "Empty do"+#if MIN_VERSION_ghc(9,0,0)+transformDo' names doName _ (L l (BindStmt _ pat body) : next) = do+#else transformDo' names doName _ (L l (BindStmt _ pat body _ _) : next) = do+#endif next' <- transformDo' names doName l next return $ hsApps l bind [ body, kont next' ] where
src/Overloaded/Plugin/Names.hs view
@@ -6,10 +6,15 @@ -- * CatNames CatNames (..), getCatNames,+ -- * RrdNames+ RdrNames (..),+ defaultRdrNames, -- * VarName VarName (..), lookupVarName, lookupTypeName,+ -- * RdrName+ mkRdrName, -- * Selected modules ghcRecordsCompatMN, ) where@@ -45,9 +50,15 @@ , doBindName :: GHC.Name , conLeftName :: GHC.Name , conRightName :: GHC.Name+ , codeFromLabelName :: GHC.Name+ , codeFromStringName :: GHC.Name , catNames :: CatNames } +data RdrNames = RdrNames+ { dollarName :: GHC.RdrName+ }+ data CatNames = CatNames { catIdentityName :: GHC.Name , catComposeName :: GHC.Name@@ -93,10 +104,18 @@ conLeftName <- lookupNameDataCon dflags env dataEitherMN "Left" conRightName <- lookupNameDataCon dflags env dataEitherMN "Right" + codeFromLabelName <- lookupName dflags env overloadedCodeLabelsMN "codeFromLabel"+ codeFromStringName <- lookupName dflags env overloadedCodeStringsMN "codeFromString"+ catNames <- getCatNames dflags env overloadedCategoriesMN return Names {..} +defaultRdrNames :: RdrNames+defaultRdrNames = RdrNames+ { dollarName = GHC.Unqual $ GHC.mkVarOcc "$"+ }+ getCatNames :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> GHC.TcM CatNames getCatNames dflags env module_ = do catIdentityName <- lookupName dflags env module_ "identity"@@ -150,6 +169,10 @@ lookupTypeName :: GHC.DynFlags -> GHC.HscEnv -> VarName -> GHC.TcM GHC.Name lookupTypeName dflags env (VN vn mn) = lookupName' dflags env (GHC.mkModuleName vn) mn +-- TODO: ignores module+mkRdrName :: VarName -> GHC.RdrName+mkRdrName (VN _ rn) = GHC.Unqual $ GHC.mkVarOcc rn+ ------------------------------------------------------------------------------- -- ModuleNames -------------------------------------------------------------------------------@@ -183,6 +206,12 @@ ghcOverloadedLabelsMN :: GHC.ModuleName ghcOverloadedLabelsMN = GHC.mkModuleName "GHC.OverloadedLabels"++overloadedCodeLabelsMN :: GHC.ModuleName+overloadedCodeLabelsMN = GHC.mkModuleName "Overloaded.CodeLabels"++overloadedCodeStringsMN :: GHC.ModuleName+overloadedCodeStringsMN = GHC.mkModuleName "Overloaded.CodeStrings" overloadedTypeNatsMN :: GHC.ModuleName overloadedTypeNatsMN = GHC.mkModuleName "Overloaded.TypeNats"
src/Overloaded/Plugin/Rewrite.hs view
@@ -12,6 +12,7 @@ data Rewrite a = NoRewrite | Rewrite a -- TODO: add warnings+ | WithName (GHC.Name -> Rewrite a) | Error (GHC.DynFlags -> IO ()) deriving (Functor) @@ -19,6 +20,10 @@ NoRewrite <> x = x x <> _ = x +instance Monoid (Rewrite a) where+ mempty = NoRewrite+ mappend = (<>)+ instance Applicative Rewrite where pure = Rewrite (<*>) = ap@@ -27,4 +32,5 @@ return = Rewrite NoRewrite >>= _ = NoRewrite Rewrite a >>= k = k a+ WithName f >>= k = WithName (\n -> f n >>= k) Error err >>= _ = Error err
test/Overloaded/Test/Categories.hs view
@@ -1,17 +1,18 @@-{-# LANGUAGE Arrows #-}+{-# LANGUAGE Arrows #-} {-# LANGUAGE PolyKinds #-} {-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Categories=Overloaded.Categories.identity #-} module Overloaded.Test.Categories where -import Data.Bifunctor.Assoc (assoc) import Test.QuickCheck ((===)) import Test.QuickCheck.Poly (A, B, C) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.QuickCheck (testProperty) -import Overloaded.Categories+import qualified Data.Bifunctor.Assoc as Assoc+ import AD+import Overloaded.Categories import STLC tests :: TestTree@@ -56,7 +57,7 @@ ] , testProperty "assoc (->)" $ \abc ->- assoc abc === catAssoc (abc :: ((A, B), C))+ Assoc.assoc abc === catAssoc (abc :: ((A, B), C)) , testCase "assoc Mapping" $ do let M rhs = catAssoc@@ -65,7 +66,7 @@ show rhs @?= lhs , testProperty "assocCo (->)" $ \abc ->- assoc abc === catAssocCo (abc :: Either (Either A B) C)+ Assoc.assoc abc === catAssocCo (abc :: Either (Either A B) C) , testCase "assocCo Mapping" $ do let M rhs = catAssocCo@@ -123,11 +124,11 @@ => Object cat a -> Object cat b -> cat c (Product cat a b)-catKonst a b = proc _ -> do- a' <- konst a -< ()- b' <- konst b -< ()+catKonst a b = proc c -> do+ a' <- konst a -< c+ b' <- konst b -< c identity -< (a', b')- + quad :: Num a => AD (a, a) a quad = proc (x, y) -> do x2 <- mult -< (x, x)
+ test/Overloaded/Test/CodeLabels.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:CodeLabels #-}+module Overloaded.Test.CodeLabels where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Overloaded+import Overloaded.Test.CodeLabels.String++tests :: TestTree+tests = testGroup "Labels"+ [ testCase "String" $ do+ -- we need type annotations :(+ -- https://gitlab.haskell.org/ghc/ghc/issues/18211+ (#foo :: String) @?= ("FOO" :: String)+ (#bar :: String) @?= ("BAR" :: String)+ ]
+ test/Overloaded/Test/CodeLabels/String.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+module Overloaded.Test.CodeLabels.String where++import Data.Char (toUpper)+import Data.Proxy (Proxy (..))+import GHC.TypeLits (KnownSymbol, symbolVal)+import Language.Haskell.TH.Syntax (lift)+import Language.Haskell.TH.Syntax.Compat (unsafeSpliceCoerce)+import Overloaded++instance (a ~ Char, KnownSymbol sym) => IsCodeLabel sym [a] where+ codeFromLabel = unsafeSpliceCoerce (lift (map toUpper (symbolVal (Proxy :: Proxy sym))))
+ test/Overloaded/Test/CodeStrings.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:CodeStrings #-}+module Overloaded.Test.CodeStrings where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import qualified Data.ByteString as BS++import Overloaded++tests :: TestTree+tests = testGroup "Labels"+ [ testCase "String" $ do+ -- we seem to need type annotations :(+ -- https://gitlab.haskell.org/ghc/ghc/issues/18211+ ("FOO" :: String) @?= ("FOO" :: String)+ ("BAR" :: String) @?= ("BAR" :: String)++ , testCase "ByteString" $ do+ ("FOO" :: BS.ByteString) @?= BS.pack [70,79,79]+ ("FOO\313" :: BS.ByteString) @?= BS.pack [70,79,79,57]+ ]
+ test/Overloaded/Test/RebindableApplications.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fplugin=Overloaded+ -fplugin-opt=Overloaded:RebindableApplication=$ #-}+module Overloaded.Test.RebindableApplications where++import Data.Char (toUpper)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Overloaded++tests :: TestTree+tests = testGroup "RebindableApplication"+ [ testCase "Normal functional application" $ do+ map toUpper "foo" @?= "FOO"++ , testCase "Applicative" $ do+ let f = pure ((+) :: Int -> Int -> Int)+ x = Just 1+ y = Just 2+ + z = let ($) = (<*>) in f x y++ z @?= Just 3+ ]
test/Regexp/Type.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}+{-# OPTIONS_GHC -Wno-orphans #-} module Regexp.Type ( Parse, Matches,
test/STLC.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wall #-} module STLC where import Data.Kind (Type)@@ -16,6 +17,7 @@ data Ty = TyUnit+ | TyVoid | TyPair Ty Ty | TyFun Ty Ty | TyCoproduct Ty Ty@@ -35,6 +37,7 @@ App :: Term ctx ('TyFun a b) -> Term ctx a -> Term ctx b Unit :: Term ctx 'TyUnit+ Absurd :: Term ctx 'TyVoid -> Term ctx a Fst :: Term ctx ('TyPair a b) -> Term ctx a Snd :: Term ctx ('TyPair a b) -> Term ctx b@@ -81,6 +84,7 @@ weakenTerm' pfx sfx a (Pair u v) = Pair (weakenTerm' pfx sfx a u) (weakenTerm' pfx sfx a v) weakenTerm' pfx sfx a (InL t) = InL (weakenTerm' pfx sfx a t) weakenTerm' pfx sfx a (InR t) = InR (weakenTerm' pfx sfx a t)+weakenTerm' pfx sfx a (Absurd t) = Absurd (weakenTerm' pfx sfx a t) weakenTerm' pfx sfx a (Case u v w) = Case (weakenTerm' (SCons pfx) sfx a u) (weakenTerm' (SCons pfx) sfx a v)@@ -153,6 +157,7 @@ subst pfx sfx (InR x) t = InR (subst pfx sfx x t) subst pfx sfx (App u v) t = app (subst pfx sfx u t) (subst pfx sfx v t) subst pfx sfx (Pair u v) t = Pair (subst pfx sfx u t) (subst pfx sfx v t)+subst pfx sfx (Absurd x) t = Absurd (subst pfx sfx x t) subst pfx sfx (Case u v w) t = tcase (subst (SCons pfx) sfx u t) (subst (SCons pfx) sfx v t)@@ -230,6 +235,11 @@ ------------------------------------------------------------------------------- -- Coproduct: Mapping -------------------------------------------------------------------------------++instance CategoryWith0 (Mapping ctx) where+ type Initial (Mapping ctx) = 'TyVoid++ initial = M $ Lam $ Absurd var0 instance CocartesianCategory (Mapping ctx) where type Coproduct (Mapping ctx) = 'TyCoproduct
test/Tests.hs view
@@ -2,23 +2,28 @@ import Test.Tasty (defaultMain, testGroup) -import qualified Overloaded.Test.Categories as Cat-import qualified Overloaded.Test.Chars as Chr-import qualified Overloaded.Test.Do as Doo-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.Categories as Cat+import qualified Overloaded.Test.Chars as Chr+import qualified Overloaded.Test.CodeLabels as Cdl+import qualified Overloaded.Test.CodeStrings as Cst+import qualified Overloaded.Test.Do as Doo+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.RebindableApplications as Rba+import qualified Overloaded.Test.Strings as Str+import qualified Overloaded.Test.Symbols as Sym import qualified Overloaded.Test.Labels.GenericLens as GL main :: IO () main = defaultMain $ testGroup "Tests" [ Chr.tests+ , Cdl.tests+ , Cst.tests , Iff.tests , Doo.tests , Lbl.tests@@ -30,4 +35,5 @@ , Sym.tests , GL.tests , Cat.tests+ , Rba.tests ]