packages feed

overloaded 0.3 → 0.3.1

raw patch · 17 files changed

+624/−145 lines, 17 filesdep +indexed-traversable

Dependencies added: indexed-traversable

Files

CHANGELOG.md view
@@ -1,3 +1,7 @@+# 0.3.1++- Add `Overloaded:Constructors`+ # 0.3  - Add `Overloaded:RebindableApplications`
example/AD.hs view
@@ -56,17 +56,15 @@ ladd (LH f g) = LA f g ladd (LV f g) = LV (ladd f) (ladd g) ladd (LA a b) = LA (ladd a) (ladd b)-ladd (LK k f) = LK k (ladd f) ladd LZ       = LZ-ladd LI       = LV LI LI+ladd (LD k)   = LV (LD k) (LD k)  lmult :: Double -> Double -> LinMap r (a, a) -> LinMap r a-lmult x y (LH f g) = LA (LK y f) (LK x g)+lmult x y (LH f g) = LA (lmul y f) (lmul x g) lmult x y (LV f g) = LV (lmult x y f) (lmult x y g) lmult x y (LA f g) = LA (lmult x y f) (lmult x y g)-lmult x y (LK k f) = LK k (lmult x y f) lmult _ _ LZ       = LZ-lmult x y LI       = LV (LK y LI) (LK x LI)+lmult x y (LD k)   = LV (LD (k * y)) (LD (k * x))  plus :: AD (Double, Double) Double plus = AD $ \(x,y) -> (x + y, L ladd)
example/VectorSpace.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE GADTs                #-}+{-# LANGUAGE PatternSynonyms      #-} {-# LANGUAGE RankNTypes           #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE StandaloneDeriving   #-}@@ -11,7 +12,8 @@ {-# OPTIONS_GHC -Wall #-} -- | This module is wrongly named. module VectorSpace (-    LinMap (..),+    LinMap (.., LI),+    lmul,     HasDim(Dim, dimDict),     toRawMatrix,     evalL,@@ -22,12 +24,12 @@     fromVector, ) where -import Data.Constraint       ((:-), Dict (..), withDict)+import Data.Constraint       (Dict (..), withDict, (:-)) import Data.Proxy            (Proxy (..)) import GHC.TypeLits import Overloaded.Categories -import qualified Control.Category+import qualified Control.Category      as C import qualified Data.Constraint.Nat   as C import qualified Numeric.LinearAlgebra as L @@ -35,22 +37,28 @@  data LinMap a b where     LZ :: LinMap a b-    LI :: LinMap a a+    LD :: Double -> LinMap a a     LH :: LinMap a b -> LinMap a c -> LinMap a (b, c)     LV :: LinMap a c -> LinMap b c -> LinMap (a, b) c     LA :: LinMap a b -> LinMap a b -> LinMap a b-    LK :: Double -> LinMap a b -> LinMap a b  deriving instance Show (LinMap a b) +pattern LI :: forall a b. () => (b ~ a) => LinMap a b+pattern LI = LD 1++lmul :: Double -> LinMap a b -> LinMap a b+lmul _ LZ       = LZ+lmul k (LD x)   = LD (k * x)+lmul k (LH f g) = LH (lmul k f) (lmul k g)+lmul k (LV f g) = LV (lmul k f) (lmul k g)+lmul k (LA f g) = LA (lmul k f) (lmul k g)+ lcomp :: LinMap b c -> LinMap a b -> LinMap a c lcomp LZ       _        = LZ lcomp _        LZ       = LZ-lcomp LI       h        = h-lcomp h        LI       = h-lcomp (LK k f) (LK l g) = LK (k * l) (lcomp f g)-lcomp (LK k f) h        = LK k (lcomp f h)-lcomp f        (LK k h) = LK k (lcomp f h)+lcomp (LD k)   h        = lmul k h+lcomp h        (LD k)   = lmul k h lcomp (LA f g) h        = LA (lcomp f h) (lcomp g h) lcomp f        (LA g h) = LA (lcomp f g) (lcomp f h) lcomp (LH f g) h        = LH (lcomp f h) (lcomp g h)@@ -58,7 +66,7 @@ lcomp (LV f g) (LH u v) = LA (lcomp f u) (lcomp g v)  instance Category LinMap where-    id = LI+    id  = LI     (.) = lcomp  instance CategoryWith1 LinMap where@@ -67,8 +75,8 @@  instance CartesianCategory LinMap where     type Product LinMap = (,)-    proj1  = LV LI LZ-    proj2  = LV LZ LI+    proj1  = LV C.id LZ+    proj2  = LV LZ C.id     fanout = LH  instance CategoryWith0 LinMap where@@ -77,8 +85,8 @@  instance CocartesianCategory LinMap where     type Coproduct LinMap = (,)-    inl   = LH LI LZ-    inr   = LH LZ LI+    inl   = LH C.id LZ+    inr   = LH LZ C.id     fanin = LV  instance BicartesianCategory LinMap where@@ -90,25 +98,23 @@  lfst :: LinMap a (b, c) -> LinMap a b lfst (LA f g) = LA (lfst f) (lfst g)-lfst (LK k f) = LK k (lfst f) lfst (LH f _) = f lfst (LV f g) = LV (lfst f) (lfst g) lfst LZ       = LZ-lfst LI       = LV LI LZ+lfst (LD k)   = LV (LD k) LZ  lsnd :: LinMap a (b, c) -> LinMap a c 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 (LD k)   = LV LZ (LD k)  linitial :: LinMap r () -> LinMap r a linitial _ = LZ  linear :: Double -> L a a-linear k = L $ LK k+linear k = L $ lmul k  -- lmult :: Double -> Double -> LinMap r (a, a) -> LinMap r a -- lmult x y (LH f g) = LA (LK y f) (LK x g)@@ -185,9 +191,8 @@  toRawMatrix :: forall a b. (HasDim a, HasDim b) => LinMap a b -> L.Matrix Double toRawMatrix LZ       = (dim (Proxy :: Proxy a) L.>< dim (Proxy :: Proxy b)) (repeat 0)-toRawMatrix LI       = L.ident (dim (Proxy :: Proxy a))+toRawMatrix (LD k)   = L.scale k (L.ident (dim (Proxy :: Proxy a))) toRawMatrix (LA f g) = L.add (toRawMatrix f) (toRawMatrix g)-toRawMatrix (LK k f) = L.scale k (toRawMatrix f) toRawMatrix (LH f g) = go splitPair f g where     go :: (Dict (HasDim x), Dict (HasDim y)) -> LinMap a x -> LinMap a y -> L.Matrix Double     go (Dict, Dict) f' g' = toRawMatrix f' L.||| toRawMatrix g'@@ -196,7 +201,7 @@     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)+evalL (L f) = toRawMatrix (f (LD 1))  -- 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.3+version:            0.3.1 synopsis:           Overloaded pragmas as a plugin description:   Implement @Overloaded@ pragmas as a source plugin@@ -39,6 +39,7 @@     Overloaded.Chars     Overloaded.CodeLabels     Overloaded.CodeStrings+    Overloaded.Constructors     Overloaded.Do     Overloaded.If     Overloaded.Lists@@ -55,11 +56,15 @@     GHC.Compat.Expr     Overloaded.Plugin.Categories     Overloaded.Plugin.Diagnostics+    Overloaded.Plugin.HasConstructor     Overloaded.Plugin.HasField     Overloaded.Plugin.IdiomBrackets     Overloaded.Plugin.LocalDo     Overloaded.Plugin.Names     Overloaded.Plugin.Rewrite+    Overloaded.Plugin.TcPlugin+    Overloaded.Plugin.TcPlugin.Ctx+    Overloaded.Plugin.TcPlugin.Utils     Overloaded.Plugin.V    -- GHC boot dependencies@@ -74,19 +79,20 @@    -- other dependencies   build-depends:-    , assoc            ^>=1.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-    , th-compat        ^>=0.1.1-    , vec              ^>=0.4+    , assoc                ^>=1.0.1+    , bin                  ^>=0.1.1+    , fin                  ^>=0.2+    , indexed-traversable  ^>=0.1.1+    , 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+    , th-compat            ^>=0.1.1+    , vec                  ^>=0.4  test-suite example   default-language: Haskell2010@@ -213,6 +219,7 @@     Overloaded.Test.CodeLabels     Overloaded.Test.CodeLabels.String     Overloaded.Test.CodeStrings+    Overloaded.Test.Constructors     Overloaded.Test.Do     Overloaded.Test.If     Overloaded.Test.Labels
src/GHC/Compat/All.hs view
@@ -7,6 +7,7 @@ ) where  #if MIN_VERSION_ghc(9,0,0)+import GHC.Builtin.Names        as X import GHC.Builtin.Types        as X import GHC.Core                 as X import GHC.Core.Class           as X@@ -39,6 +40,8 @@ import GHC.Utils.Error          as X import GHC.Utils.Outputable     as X +import GHC     as X (Module)+ import qualified GHC.Core.TyCo.Rep as GHC  #else@@ -59,13 +62,14 @@ import FamInst    as X import FamInstEnv as X import Finder     as X-import GHC        as X (HscEnv)+import HscTypes   as X import Id         as X import IfaceEnv   as X import MkCore     as X import Module     as X import Name       as X import Outputable as X+import PrelNames  as X import RdrName    as X import SrcLoc     as X import TcEnv      as X
src/GHC/Compat/Expr.hs view
@@ -17,7 +17,9 @@     -- ** Constructors     hsVar,     hsApps,+    hsApps_RDR,     hsTyApp,+    hsTyApp_RDR,     hsTyVar,     hsPar,     hsOpApp,@@ -115,6 +117,11 @@     app :: LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn     app f x = L l (HsApp noExtField f x) +hsApps_RDR :: SrcSpan -> LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs+hsApps_RDR l = foldl' app where+    app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+    app f x = L l (HsApp noExtField f x)+ hsOpApp :: SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn hsOpApp l x op y = L l (OpApp GHC.defaultFixity x op y) @@ -123,6 +130,13 @@ hsTyApp l x ty = L l $ HsAppType noExtField x (HsWC [] (L l ty)) #else hsTyApp l x ty = L l $ HsAppType (HsWC [] (L l ty)) x+#endif++hsTyApp_RDR :: SrcSpan -> LHsExpr GhcPs -> HsType GhcPs -> LHsExpr GhcPs+#if MIN_VERSION_ghc(8,8,0)+hsTyApp_RDR l x ty = L l $ HsAppType noExtField x (HsWC noExtField (L l ty))+#else+hsTyApp_RDR l x ty = L l $ HsAppType (HsWC noExtField (L l ty)) x #endif  hsPar :: SrcSpan -> LHsExpr GhcRn -> LHsExpr GhcRn
+ src/Overloaded/Constructors.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE PolyKinds              #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+module Overloaded.Constructors where++import Data.Kind (Type)++-- | Class for the overloaded constructors.+--+-- Instances for this class are automatically generated by type-checker+-- plugin, but you may also defined your own. See an example instances for 'Either'.+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Constructors #-}+-- @+--+-- Additionally, this overload steals syntax transforming all+-- @(:name arg1 arg2)@ into @'build' \@"name" (arg1, arg2)@ expressions.+-- Parenthesis are important as standalone @:name@ is (for now) not valid+-- Haskell syntax and they also naturally delimit the arguments.+--+-- For nullary constructors the @a@ type is unit @()@,+-- for unary the type is used as is,+-- and for others the parameters are wrapped into a tuple.+-- The last case is not particularly pretty, but its overloadable.+--+--+class HasConstructor x (s :: Type) (a :: Type) | x s -> a where+    build :: a -> s+    match :: s -> Maybe a++-------------------------------------------------------------------------------+-- An example+-------------------------------------------------------------------------------++instance a' ~ a => HasConstructor "Left" (Either a b) a' where+    build = Left+    match = \s -> case s of+        Left a  -> Just a+        Right _ -> Nothing++instance a' ~ b => HasConstructor "Right" (Either a b) a' where+    build = Right+    match = \s -> case s of+        Left _  -> Nothing+        Right b -> Just b
src/Overloaded/Plugin.hs view
@@ -18,18 +18,18 @@ import           GHC.Compat.Expr  #if MIN_VERSION_ghc(9,0,0)-import qualified GHC.Plugins     as Plugins+import qualified GHC.Plugins as Plugins #else-import qualified GhcPlugins      as Plugins+import qualified GhcPlugins as Plugins #endif  import Overloaded.Plugin.Categories import Overloaded.Plugin.Diagnostics-import Overloaded.Plugin.HasField import Overloaded.Plugin.IdiomBrackets import Overloaded.Plugin.LocalDo import Overloaded.Plugin.Names import Overloaded.Plugin.Rewrite+import Overloaded.Plugin.TcPlugin import Overloaded.Plugin.V  -------------------------------------------------------------------------------@@ -77,6 +77,7 @@ -- * @CodeLabels@ desugars @OverloadedLabels@ into Typed Template Haskell splices -- * @CodeStrings@ desugars string literals into Typed Template Haskell splices -- * @RebindableApplication@ changes how juxtaposition is interpreted+-- * @OverloadedConstructors@ allows you to use overloaded constructor names! -- -- == Known limitations --@@ -157,7 +158,7 @@ -- let f = pure ((+) :: Int -> Int -> Int) --     x = Just 1 --     y = Just 2--- +-- --     z = let ($) = ('<*>') in f x y -- in z -- @@@ -172,9 +173,10 @@   where     enabled p args'         | "RecordFields" `elem` args = Just p+        | "Constructors" `elem` args = Just p         | otherwise                  = Nothing       where-        args = concatMap (splitOn ":") args'+        args = map (takeWhile (/= '=')) $ concatMap (splitOn ":") args'  ------------------------------------------------------------------------------- -- Renamer@@ -327,13 +329,14 @@     -> Plugins.Hsc Plugins.HsParsedModule parsedAction args _modSum pm = do     let hsmodule = Plugins.hpm_module pm+    topEnv <- GHC.Hsc $ \env warnMsgs -> return (env, warnMsgs)      dflags <- GHC.getDynFlags      debug $ show args     debug $ GHC.showPpr dflags hsmodule -    let names = defaultRdrNames+    names <- getRdrNames dflags topEnv     _opts@Options {..} <- parseArgs dflags args      let transformNoOp :: a -> Rewrite a@@ -346,7 +349,19 @@             let n = mkRdrName rn             return $ transformRebindableApplication $ names { dollarName = n } -    hsmodule' <- transformPs dflags trRebindApp hsmodule+    trConstructors <- case optConstructors of+        Off -> return transformNoOp+        On Nothing -> return $ transformConstructors names+        On (Just rn) -> do+            let n = mkRdrName rn+            return $ transformConstructors $ names { buildName = n }++    let tr  = mconcat+            [ trRebindApp+            , trConstructors+            ]++    hsmodule' <- transformPs dflags tr hsmodule     let pm' = pm { Plugins.hpm_module = hsmodule' }      return pm'@@ -440,6 +455,9 @@     go opts "RebindableApplication" vns = do         mrn <- oneName "RebindableApplication" vns         return $ opts { optRebindApp = On mrn }+    go opts "Constructors" vns = do+        mrn <- oneName "Constructors" vns+        return $ opts { optConstructors = On mrn }      go opts s _ = do         warn dflags noSrcSpan $ GHC.text $ "Unknown Overloaded option " ++  show s@@ -491,6 +509,7 @@     , optDo            :: Bool     , optCategories    :: OnOff String -- module name     , optRebindApp     :: OnOff VarName+    , optConstructors  :: OnOff VarName     }   deriving (Eq, Show) @@ -510,6 +529,7 @@     , optDo            = False     , optCategories    = Off     , optRebindApp     = Off+    , optConstructors  = Off     }  data StrSym@@ -741,6 +761,38 @@   where     l' = GHC.mkSrcSpan (GHC.srcSpanEnd fl) (GHC.srcSpanStart xl) transformRebindableApplication _ _ = NoRewrite++-------------------------------------------------------------------------------+-- Constructors+-------------------------------------------------------------------------------++transformConstructors :: RdrNames -> LHsExpr GhcPs -> Rewrite (LHsExpr GhcPs)+transformConstructors RdrNames {..} (L l (SectionR _ (L lop (HsVar _ (L _ op))) arg))+    | op == GHC.consDataCon_RDR+    , (L _ (HsVar _ (L _ln n)), xs) <- splitHsApps arg+    = Rewrite $ expr n xs+  where+    expr n args = hsApps_RDR l+        (hsTyApp_RDR l+            (L lop (HsVar noExtField (L lop buildName)))+            (HsTyLit noExtField (HsStrTy GHC.NoSourceText (Plugins.occNameFS (GHC.rdrNameOcc n)))))+        [ args' ]+      where+        args' = case args of+            [x] -> x+            _   -> L l (ExplicitTuple noExtField [ L l' (Present noExtField x) | x@(L l' _) <- args ] Plugins.Boxed)++transformConstructors _ _ = NoRewrite++splitHsApps :: LHsExpr GhcPs -> (LHsExpr GhcPs, [LHsExpr GhcPs])+splitHsApps e = go e []+  where+    go :: LHsExpr GhcPs -> [LHsExpr GhcPs]+       -> (LHsExpr GhcPs, [LHsExpr GhcPs])+    go (L _ (HsApp _ f x))      xs = go f (x : xs)+    go f                        xs = (f, xs)++  ------------------------------------------------------------------------------- -- Transform
+ src/Overloaded/Plugin/HasConstructor.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+module Overloaded.Plugin.HasConstructor where++import Control.Monad (forM)+import Data.List     (find)+import Data.Maybe    (mapMaybe)++import qualified GHC.Compat.All  as GHC++#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.TcPlugin.Ctx+import Overloaded.Plugin.TcPlugin.Utils+import Overloaded.Plugin.V++ifDebug :: Monad m => m () -> m ()+ifDebug _ = return ()++solveHasConstructor+    :: PluginCtx+    -> GHC.DynFlags+    -> (GHC.FamInstEnv, GHC.FamInstEnv)+    -> GHC.GlobalRdrEnv+    -> [GHC.Ct]+    -> Plugins.TcPluginM [(Maybe (GHC.EvTerm, [GHC.Ct]), GHC.Ct)]+solveHasConstructor PluginCtx {..} dflags famInstEnvs rdrEnv wanteds =+    forM wantedsHasPolyCon $ \(ct, tys@(V4 _k _name _s a)) -> do+        -- Plugins.tcPluginIO $ warn dflags noSrcSpan $+        --     GHC.text "HasConstructor wanted" GHC.<+> GHC.ppr ct++        m <- GHC.unsafeTcPluginTcM $ matchHasConstructor dflags famInstEnvs rdrEnv tys+        fmap (\evTerm -> (evTerm, ct)) $ forM m $ \(tc, dc, args, xs) -> do+            -- get location+            let ctloc = GHC.ctLoc ct+            let l = GHC.RealSrcSpan (GHC.ctLocSpan ctloc)+#if MIN_VERSION_ghc(9,0,0)+                        Nothing+#endif++            ifDebug $ Plugins.tcPluginIO $ warn dflags l $+                GHC.text "DEBUG1"+                    GHC.$$ GHC.ppr tc+                    GHC.$$ GHC.ppr dc+                    GHC.$$ GHC.ppr args+                    GHC.$$ GHC.ppr xs++            -- "s"+            let s' = GHC.mkTyConApp tc args++            -- type of constructor fields:+            -- - for unary constructors we use the field+            -- - for nullary we use unit+            -- - for others we wrap them in tuple.+            let a' :: GHC.Type+                a' = case xs of+                    [x] -> x+                    _   -> GHC.mkBoxedTupleTy xs+                    -- TODO: nullary+                    -- TODO: multiple++            -- let b' = a'+            --     t' = s'++            let tupleDataCon :: GHC.DataCon+                tupleDataCon = GHC.tupleDataCon GHC.Boxed (length xs)++            ifDebug $ Plugins.tcPluginIO $ warn dflags l $+                GHC.text "DEBUG2"+                    GHC.$$ GHC.ppr s'+                    GHC.$$ GHC.ppr a'++            -- build+            exprBuild <- case xs of+                -- unary: \a -> DC a+                [_] -> do+                    x <- makeVar "x" a'+                    return $ GHC.mkCoreLams [x] $ GHC.mkConApp2 dc args [x]++                -- nullary: \ (_unused :: ()) -> DC+                [] -> do+                    unused <- makeVar "_unused" a'+                    return $ GHC.mkCoreLams [unused] $ GHC.mkConApp2 dc args []++                -- multi: \ (a :: a) -> case a of+                --    (x1, ..., xn) -> DC x1 ... xn+                _ -> do+                    aBndr <- makeVar "a" a'+                    xs' <- makeVars "x" xs+                    return $ GHC.mkCoreLams [aBndr] $ GHC.Case (GHC.Var aBndr) aBndr s'+                        [( GHC.DataAlt tupleDataCon  -- (,,,)+                        , xs'                        -- x1 ... xn+                        , GHC.mkConApp2 dc args xs'  -- DC x1 ... xn+                        )]++            ifDebug $ Plugins.tcPluginIO $ warn dflags l $+                GHC.text "DEBUG-build"+                    GHC.$$ GHC.ppr exprBuild++            -- match+            exprMatch <- case xs of+                -- unary: \s -> case s of+                --            DC a -> Just a+                --            _    -> Nothing+                [_] -> do+                    sBndr <- makeVar "s" s'+                    aBndr <- makeVar "a" a'+                    return $ GHC.mkCoreLams [sBndr] $ GHC.Case (GHC.Var sBndr) sBndr+                        (GHC.mkTyConApp GHC.maybeTyCon [a'])+                        -- default case have to be first.+                        [ (GHC.DEFAULT, [], GHC.mkConApp2 GHC.nothingDataCon [a'] [])+                        , (GHC.DataAlt dc, [aBndr], GHC.mkConApp2 GHC.justDataCon [a'] [aBndr])+                        ]++                -- nullary: \s -> case s of+                --              DC -> Just ()+                --              _  -> Nothing+                [] -> do+                    sBndr <- makeVar "s" s'+                    return $ GHC.mkCoreLams [sBndr] $ GHC.Case (GHC.Var sBndr) sBndr+                        (GHC.mkTyConApp GHC.maybeTyCon [a'])+                        [ (GHC.DEFAULT, [], GHC.mkConApp2 GHC.nothingDataCon [a'] [])+                        , (GHC.DataAlt dc, [], GHC.mkConApp2 GHC.justDataCon [a'] [GHC.unitDataConId])+                        ]++                -- multi: \s -> case s of+                --            DC x1 ... xn -> let a = (x1, ... xn) in Just a+                --            _            -> Nothing+                _ -> do+                    sBndr <- makeVar "s" s'+                    aBndr <- makeVar "a" a'+                    xs' <- makeVars "x" xs++                    return $ GHC.mkCoreLams [sBndr] $ GHC.Case (GHC.Var sBndr) sBndr+                        (GHC.mkTyConApp GHC.maybeTyCon [a'])+                        [ (GHC.DEFAULT, [], GHC.mkConApp2 GHC.nothingDataCon [a'] [])+                        , (GHC.DataAlt dc, xs',+                          GHC.Let (GHC.NonRec aBndr $ GHC.mkConApp2 tupleDataCon xs xs') $+                          GHC.mkConApp2 GHC.justDataCon [a'] [aBndr])+                        ]++            ifDebug $ Plugins.tcPluginIO $ warn dflags l $+                GHC.text "DEBUG-match"+                    GHC.$$ GHC.ppr exprMatch++            -- wanteds+            let evterm = makeEvidence4_2 hasPolyConCls exprBuild exprMatch tys+            ctEvidence <- Plugins.newWanted ctloc $ GHC.mkPrimEqPred a a'++            return (evterm, [ GHC.mkNonCanonical ctEvidence -- a ~ a'+                            ])++  where+    wantedsHasPolyCon = mapMaybe (findClassConstraint4 hasPolyConCls) wanteds++matchHasConstructor+    :: GHC.DynFlags+    -> (GHC.FamInstEnv, GHC.FamInstEnv)+    -> GHC.GlobalRdrEnv+    -> V4 GHC.Type+    -> GHC.TcM (Maybe (GHC.TyCon, GHC.DataCon, [GHC.Type], [GHC.Type]))+matchHasConstructor _dflags famInstEnvs _rdrEnv (V4 _k x s _a)+    -- x should be a literal string+    | Just xStr <- GHC.isStrLitTy x+    -- s should be an applied type constructor+    , Just (tc, args) <- GHC.tcSplitTyConApp_maybe s+    -- use representation tycon (if data family); it has the fields+    , let s_tc = fstOf3 (GHC.tcLookupDataFamInst famInstEnvs tc args)+    -- x should be constructor of r+    , Just dcs <- GHC.tyConDataCons_maybe s_tc+    , Just dc  <- find (\dc -> GHC.getOccFS (GHC.dataConName dc) == xStr) dcs+    -- TODO: check that data con is in scope++    -- check that exist and theta are empty, this makes things simpler!+    , ([], [], xs) <- GHC.dataConInstSig dc args++    = return $ Just (tc, dc, args, xs)++matchHasConstructor _ _ _ _ = return Nothing++
src/Overloaded/Plugin/HasField.hs view
@@ -2,12 +2,11 @@ {-# LANGUAGE RecordWildCards #-} module Overloaded.Plugin.HasField where -import Control.Monad (forM, guard, unless)+import Control.Monad (forM, unless) import Data.List     (elemIndex) import Data.Maybe    (mapMaybe)  import qualified GHC.Compat.All  as GHC-import           GHC.Compat.Expr  #if MIN_VERSION_ghc(9,0,0) import qualified GHC.Tc.Plugin as Plugins@@ -15,46 +14,20 @@ import qualified TcPluginM as Plugins #endif -import Overloaded.Plugin.Diagnostics-import Overloaded.Plugin.Names import Overloaded.Plugin.V--newtype PluginCtx = PluginCtx-    { hasPolyFieldCls :: GHC.Class-    }--tcPlugin :: GHC.TcPlugin-tcPlugin = GHC.TcPlugin-    { GHC.tcPluginInit  = tcPluginInit-    , GHC.tcPluginSolve = tcPluginSolve-    , GHC.tcPluginStop  = const (return ())-    }--tcPluginInit :: GHC.TcPluginM PluginCtx-tcPluginInit = do-    -- TODO: don't fail-    res <- Plugins.findImportedModule ghcRecordsCompatMN Nothing-    cls <- case res of-        GHC.Found _ md -> Plugins.tcLookupClass =<< Plugins.lookupOrig md (GHC.mkTcOcc "HasField")-        _              -> do-            dflags <- GHC.unsafeTcPluginTcM GHC.getDynFlags-            Plugins.tcPluginIO $ putError dflags noSrcSpan  $-                GHC.text "Cannot find module" GHC.<+> GHC.ppr ghcRecordsCompatMN-            fail "panic!"--    return PluginCtx-        { hasPolyFieldCls = cls-        }+import Overloaded.Plugin.TcPlugin.Ctx+import Overloaded.Plugin.TcPlugin.Utils  -- HasPolyField "petName" Pet Pet [Char] [Char]-tcPluginSolve :: PluginCtx -> GHC.TcPluginSolver-tcPluginSolve PluginCtx {..} _ _ wanteds = do-    -- acquire context-    dflags      <- Plugins.unsafeTcPluginTcM GHC.getDynFlags-    famInstEnvs <- Plugins.getFamInstEnvs-    rdrEnv      <- Plugins.unsafeTcPluginTcM GHC.getGlobalRdrEnv--    solved <- forM wantedsHasPolyField $ \(ct, tys@(V4 _k _name _s a)) -> do+solveHasField+    :: PluginCtx+    -> GHC.DynFlags+    -> (GHC.FamInstEnv, GHC.FamInstEnv)+    -> GHC.GlobalRdrEnv+    -> [GHC.Ct]+    -> Plugins.TcPluginM [(Maybe (GHC.EvTerm, [GHC.Ct]), GHC.Ct)]+solveHasField PluginCtx {..} dflags famInstEnvs rdrEnv wanteds =+    forM wantedsHasPolyField $ \(ct, tys@(V4 _k _name _s a)) -> do         -- GHC.tcPluginIO $ warn dflags noSrcSpan $         --     GHC.text "wanted" GHC.<+> GHC.ppr ct @@ -88,8 +61,7 @@             let b' = a'             let t' = s' -            bName <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc "b")-            let bBndr   = GHC.mkLocalMultId bName $ xs !! idx+            bBndr <- makeVar "b" (xs !! idx)              -- (\b -> DC b x1 x2, x0)             let rhs = GHC.mkConApp (GHC.tupleDataCon GHC.Boxed 2)@@ -120,58 +92,22 @@             sName <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc "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+            let evterm = makeEvidence4_1 hasPolyFieldCls expr tys              -- wanteds             ctEvidence <- Plugins.newWanted ctloc $ GHC.mkPrimEqPred a a'              return (evterm, [ GHC.mkNonCanonical ctEvidence -- a ~ a'                             ])--    return $ GHC.TcPluginOk (mapMaybe extractA solved) (concat $ mapMaybe extractB solved)   where     wantedsHasPolyField = mapMaybe (findClassConstraint4 hasPolyFieldCls) wanteds -    extractA (Nothing, _)     = Nothing-    extractA (Just (a, _), b) = Just (a, b)--    extractB (Nothing, _)      = Nothing-    extractB (Just (_, ct), _) = Just ct- replace :: Int -> a -> [a] -> [a] replace _ _ []     = [] replace 0 y (_:xs) = y:xs replace n y (x:xs) = x : replace (pred n) y xs -makeVar :: String -> GHC.Type -> GHC.TcPluginM GHC.Var-makeVar n ty = do-    name <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc n)-    return (GHC.mkLocalMultId name ty)- ---------------------------------------------------------------------------------- Simple Ct operations----------------------------------------------------------------------------------findClassConstraint4 :: GHC.Class -> GHC.Ct -> Maybe (GHC.Ct, V4 GHC.Type)-findClassConstraint4 cls ct = do-   (cls', [k, x, s, a]) <- GHC.getClassPredTys_maybe (GHC.ctPred ct)-   guard (cls' == cls)-   return (ct, V4 k x s a)---- | Make newtype class evidence-makeEvidence4 :: GHC.Class -> GHC.CoreExpr -> V4 GHC.Type -> GHC.EvTerm-makeEvidence4 cls e (V4 k x s a) = GHC.EvExpr appDc where-    tyCon = GHC.classTyCon cls-    dc    = GHC.tyConSingleDataCon tyCon-    appDc = GHC.mkCoreConApps dc-        [ GHC.Type k-        , GHC.Type x-        , GHC.Type s-        , GHC.Type a-        , e-        ]--------------------------------------------------------------------------------- -- Adopted from GHC ------------------------------------------------------------------------------- @@ -206,10 +142,3 @@         else return Nothing  matchHasField _ _ _ _ = return Nothing------------------------------------------------------------------------------------ Utils----------------------------------------------------------------------------------fstOf3 :: (a, b, c) -> a-fstOf3 (a, _, _) =  a
src/Overloaded/Plugin/Names.hs view
@@ -8,7 +8,7 @@     getCatNames,     -- * RrdNames     RdrNames (..),-    defaultRdrNames,+    getRdrNames,     -- * VarName     VarName (..),     lookupVarName,@@ -17,6 +17,7 @@     mkRdrName,     -- * Selected modules     ghcRecordsCompatMN,+    overloadedConstructorsMN,     ) where  import Control.Monad.IO.Class (MonadIO (..))@@ -57,6 +58,7 @@  data RdrNames = RdrNames     { dollarName         :: GHC.RdrName+    , buildName          :: GHC.RdrName     }  data CatNames = CatNames@@ -107,15 +109,18 @@     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 "$"-    }+getRdrNames :: GHC.DynFlags -> GHC.HscEnv -> GHC.Hsc RdrNames+getRdrNames dflags env = do+    let dollarName = GHC.Exact GHC.dollarName+    buildName <- GHC.Exact <$> lookupName dflags env overloadedConstructorsMN "build" +    return RdrNames {..}+ getCatNames :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> GHC.TcM CatNames getCatNames dflags env module_ = do     catIdentityName <- lookupName dflags env module_ "identity"@@ -132,11 +137,11 @@      return CatNames {..} -lookupName :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> GHC.TcM GHC.Name-lookupName dflags env mn vn = do-    res <-  liftIO $ GHC.findImportedModule env mn Nothing+lookupName :: MonadIO m => GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> m GHC.Name+lookupName dflags env mn vn = liftIO $ do+    res <- GHC.findImportedModule env mn Nothing     case res of-        GHC.Found _ md -> GHC.lookupOrig md (GHC.mkVarOcc vn)+        GHC.Found _ md -> GHC.lookupOrigIO env md (GHC.mkVarOcc vn)         _              -> do             putError dflags noSrcSpan $ GHC.text "Cannot find module" GHC.<+> GHC.ppr mn             fail "panic!"@@ -218,6 +223,9 @@  overloadedTypeSymbolsMN :: GHC.ModuleName overloadedTypeSymbolsMN =  GHC.mkModuleName "Overloaded.TypeSymbols"++overloadedConstructorsMN :: GHC.ModuleName+overloadedConstructorsMN =  GHC.mkModuleName "Overloaded.Constructors"  ghcRecordsCompatMN :: GHC.ModuleName ghcRecordsCompatMN =  GHC.mkModuleName "GHC.Records.Compat"
+ src/Overloaded/Plugin/TcPlugin.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RecordWildCards #-}+module Overloaded.Plugin.TcPlugin (+    tcPlugin,+) where++import Data.Maybe    (mapMaybe)++import qualified GHC.Compat.All  as GHC++#if MIN_VERSION_ghc(9,0,0)+import qualified GHC.Tc.Plugin as Plugins+#else+import qualified TcPluginM as Plugins+#endif++import Overloaded.Plugin.TcPlugin.Ctx+import Overloaded.Plugin.HasField+import Overloaded.Plugin.HasConstructor++-- TODO: take argument which options to enable.+tcPlugin :: GHC.TcPlugin+tcPlugin = GHC.TcPlugin+    { GHC.tcPluginInit  = tcPluginInit+    , GHC.tcPluginSolve = tcPluginSolve+    , GHC.tcPluginStop  = const (return ())+    }++-- HasPolyField "petName" Pet Pet [Char] [Char]+tcPluginSolve :: PluginCtx -> GHC.TcPluginSolver+tcPluginSolve ctx _ _ wanteds = do+    -- acquire context+    dflags      <- Plugins.unsafeTcPluginTcM GHC.getDynFlags+    famInstEnvs <- Plugins.getFamInstEnvs+    rdrEnv      <- Plugins.unsafeTcPluginTcM GHC.getGlobalRdrEnv++    solvedHasField       <- solveHasField       ctx dflags famInstEnvs rdrEnv wanteds+    solvedHasConstructor <- solveHasConstructor ctx dflags famInstEnvs rdrEnv wanteds++    let solved = solvedHasField ++ solvedHasConstructor++    return $ GHC.TcPluginOk (mapMaybe extractA solved) (concat $ mapMaybe extractB solved)+  where+    extractA (Nothing, _)     = Nothing+    extractA (Just (a, _), b) = Just (a, b)++    extractB (Nothing, _)      = Nothing+    extractB (Just (_, ct), _) = Just ct
+ src/Overloaded/Plugin/TcPlugin/Ctx.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP             #-}+module Overloaded.Plugin.TcPlugin.Ctx where++import qualified GHC.Compat.All  as GHC+import           GHC.Compat.Expr++#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++data PluginCtx = PluginCtx+    { hasPolyFieldCls :: GHC.Class+    , hasPolyConCls   :: GHC.Class+    }++tcPluginInit :: GHC.TcPluginM PluginCtx+tcPluginInit = do+    dflags <- GHC.unsafeTcPluginTcM GHC.getDynFlags++    let findModule :: GHC.ModuleName -> Plugins.TcPluginM GHC.Module+        findModule m = do+            im <- Plugins.findImportedModule m Nothing+            case im of+                GHC.Found _ md -> return md+                _              -> do+                    Plugins.tcPluginIO $ putError dflags noSrcSpan  $+                        GHC.text "Cannot find module" GHC.<+> GHC.ppr m +                    fail "panic!"++    hasPolyFieldCls <- do+        md <- findModule ghcRecordsCompatMN+        Plugins.tcLookupClass =<< Plugins.lookupOrig md (GHC.mkTcOcc "HasField")++    hasPolyConCls <- do+        md <- findModule overloadedConstructorsMN+        Plugins.tcLookupClass =<< Plugins.lookupOrig md (GHC.mkTcOcc "HasConstructor")++    return PluginCtx {..}
+ src/Overloaded/Plugin/TcPlugin/Utils.hs view
@@ -0,0 +1,65 @@+module Overloaded.Plugin.TcPlugin.Utils where++import Control.Monad              (guard)+import Data.Traversable.WithIndex (itraverse)++import qualified GHC.Compat.All as GHC++import Overloaded.Plugin.V++-------------------------------------------------------------------------------+-- Simple Ct operations+-------------------------------------------------------------------------------++findClassConstraint4 :: GHC.Class -> GHC.Ct -> Maybe (GHC.Ct, V4 GHC.Type)+findClassConstraint4 cls ct = do+   (cls', [k, x, s, a]) <- GHC.getClassPredTys_maybe (GHC.ctPred ct)+   guard (cls' == cls)+   return (ct, V4 k x s a)++-- | Make newtype class evidence+makeEvidence4_1 :: GHC.Class -> GHC.CoreExpr -> V4 GHC.Type -> GHC.EvTerm+makeEvidence4_1 cls e (V4 k x s a) = GHC.EvExpr appDc where+    tyCon = GHC.classTyCon cls+    dc    = GHC.tyConSingleDataCon tyCon+    appDc = GHC.mkCoreConApps dc+        [ GHC.Type k+        , GHC.Type x+        , GHC.Type s+        , GHC.Type a+        , e+        ]++makeEvidence4_2 :: GHC.Class -> GHC.CoreExpr -> GHC.CoreExpr -> V4 GHC.Type -> GHC.EvTerm+makeEvidence4_2 cls e1 e2 (V4 k x s a) = GHC.EvExpr appDc where+    tyCon = GHC.classTyCon cls+    dc    = GHC.tyConSingleDataCon tyCon+    appDc = GHC.mkCoreConApps dc+        [ GHC.Type k+        , GHC.Type x+        , GHC.Type s+        , GHC.Type a+        , e1+        , e2+        ]++++-------------------------------------------------------------------------------+-- makeVar+-------------------------------------------------------------------------------++makeVar :: String -> GHC.Type -> GHC.TcPluginM GHC.Var+makeVar n ty = do+    name <- GHC.unsafeTcPluginTcM $ GHC.newName (GHC.mkVarOcc n)+    return (GHC.mkLocalMultId name ty)++makeVars :: String -> [GHC.Type] -> GHC.TcPluginM [GHC.Var]+makeVars n tys = itraverse (\i -> makeVar (n ++ show i)) tys++-------------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------------++fstOf3 :: (a, b, c) -> a+fstOf3 (a, _, _) =  a
+ test/Overloaded/Test/Constructors.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS+    -fplugin=Overloaded+    -fplugin-opt=Overloaded:Constructors=build+    -dcore-lint+  #-}+module Overloaded.Test.Constructors where++import Test.Tasty       (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++import Overloaded.Constructors++tests :: TestTree+tests = testGroup "Constructors"+    [ testGroup "build"+        [ testCase "Left" $+            build @"Left" ('x') @?= (Left 'x' :: Either Char Int)++        , testCase "Just" $+            build @"Just" ('x') @?= Just 'x'++        , testCase "Foobar Foo" $+            build @"Foo" () @?= Foo++        , testCase "Foobar Bar" $+            build @"Bar" ("here", 4.2) @?= Bar "here" 4.2+        ]++    , testGroup "match"+        [ testCase "Just" $ do+            match @"Just" (Nothing :: Maybe Char) @?= Nothing+            match @"Just" (Just 'x':: Maybe Char) @?= Just 'x'++        , testCase "Foobar Foo" $ do+            match @"Foo" Foo              @?= Just ()+            match @"Foo" (Bar "here" 4.2) @?= Nothing++        , testCase "Foobar Bar" $ do+            match @"Bar" Foo              @?= Nothing+            match @"Bar" (Bar "here" 4.2) @?= Just ("here", 4.2)+        ]++    -- Source plugin rewrites (:name arg1 arg2 arg3)+    -- into build @name (arg1, arg2, arg3).+    , testGroup "Overloaded build"+        [ testCase "Left" $+            (:Left 'x') @?= (Left 'x' :: Either Char Int)++        , testCase "Foobar" $ do+            (:Foo)            @?= Foo+            (:Bar "here" 4.2) @?= Bar "here" 4.2+        ]+    ]++data Foobar+    = Foo+    | Bar String Rational+  deriving (Eq, Show)
test/Overloaded/Test/RecordFields.hs view
@@ -10,7 +10,7 @@ import Test.Tasty.HUnit (testCase, (@?=))  tests :: TestTree-tests = testGroup "Strings"+tests = testGroup "RecordFields"     [ testCase "view" $         view #petName bob @?= "bob"     , testCase "over" $
test/Tests.hs view
@@ -6,6 +6,7 @@ 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.Constructors           as Con import qualified Overloaded.Test.Do                     as Doo import qualified Overloaded.Test.If                     as Iff import qualified Overloaded.Test.Labels                 as Lbl@@ -14,6 +15,7 @@ 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.RecordFields           as Rec import qualified Overloaded.Test.Strings                as Str import qualified Overloaded.Test.Symbols                as Sym @@ -36,4 +38,6 @@     , GL.tests     , Cat.tests     , Rba.tests+    , Rec.tests+    , Con.tests     ]