overloaded 0.1.1 → 0.1.2
raw patch · 9 files changed
+607/−37 lines, 9 filesdep +optics-coredep +record-hasfielddep ~basedep ~tastydep ~tasty-hunitPVP ok
version bump matches the API change (PVP)
Dependencies added: optics-core, record-hasfield
Dependency ranges changed: base, tasty, tasty-hunit, vec
API changes (from Hackage documentation)
+ Overloaded.Plugin: instance GHC.Classes.Eq a => GHC.Classes.Eq (Overloaded.Plugin.V4 a)
+ Overloaded.Plugin: instance GHC.Show.Show a => GHC.Show.Show (Overloaded.Plugin.V4 a)
Files
- CHANGELOG.md +5/−0
- example/Example.hs +0/−1
- example/IdiomBrackets.hs +42/−0
- example/RecordFields.hs +29/−0
- optics-hasfield/Optics/HasField.hs +16/−0
- overloaded.cabal +56/−7
- src/Overloaded.hs +4/−1
- src/Overloaded/Plugin.hs +427/−28
- test/Overloaded/Test/RecordFields.hs +28/−0
CHANGELOG.md view
@@ -1,3 +1,8 @@+# 0.1.2++- Add `Overloaded:RecordFields` type-checker plugin to emulate `HasField` from [`GHC.Record.Compat`](https://hackage.haskell.org/package/record-hasfield-1.0/docs/GHC-Records-Compat.html)+- Add `Overloaded:IdiomBrackets` to turn `TemplateHaskellQuotes` into [*idiom brackets*](http://www.staff.city.ac.uk/~ross/papers/Applicative.html)+ # 0.1.1 - Add `Overloaded.TypeNats` and `Overloaded.TypeSymbols`
example/Example.hs view
@@ -108,4 +108,3 @@ (if True then 'x' else 'y') @?= ('x' :: Char) (if Just 'b' then 'x' else 'y') @?= ('x' :: Char) -
+ example/IdiomBrackets.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# OPTIONS_GHC -fplugin=Overloaded -fplugin-opt=Overloaded:IdiomBrackets #-}+module Main (main) where++import Data.Traversable (foldMapDefault)++-------------------------------------------------------------------------------+-- Traversable looks like Functor+-------------------------------------------------------------------------------++data Tree a+ = Leaf a+ | Branch (Tree a) (Tree a)+ deriving (Show)++instance Functor Tree where+ fmap f (Leaf x) = Leaf (f x)+ fmap f (Branch l r) = Branch (fmap f l) (fmap f r)++instance Traversable Tree where+ traverse f (Leaf x) = [| Leaf (f x) |]+ traverse f (Branch l r) = [| Branch (traverse f l) (traverse f r) |]++instance Foldable Tree where+ foldMap = foldMapDefault++-------------------------------------------------------------------------------+-- Main+-------------------------------------------------------------------------------++main :: IO ()+main = do+ -- traverse a tree+ let tree = Branch (Branch (Leaf 'x') (Leaf 'y')) (Leaf 'z')+ tree' <- traverse print tree+ print tree'++ -- operators+ let xs :: [Int]+ xs = [| [1..4] * [1..4] |]++ print xs
+ example/RecordFields.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS_GHC -fplugin=Overloaded -fplugin-opt=Overloaded:RecordFields #-}+{-# OPTIONS_GHC -dcore-lint #-}+-- {-# OPTIONS_GHC -ddump-simpl #-}+{-# OPTIONS_GHC -O0 #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+module Main (main) where++import Test.HUnit ((@?=))++import GHC.Records.Compat+import GHC.Records.Extra++main :: IO ()+main = do+ -- Overloaded:RecordFields+ let bob = MkCat "Bob" (3 :: Int) ""+ getField @"petName" bob @?= "Bob"+ setField @"petExtra" bob "foo" @?= bob { petExtra = "foo" }+ modifyField @"petAge" bob succ @?= bob { petAge = 4 }++ print $ getField @"petName" bob++data Pet u = MkCat+ { petName :: String+ , petAge :: Int+ , petExtra :: u+ }+ deriving (Eq, Show)
+ optics-hasfield/Optics/HasField.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Optics.HasField (field) where++import GHC.Records.Compat (HasField (..))+import GHC.TypeLits (Symbol)+import Optics.Core (Lens', lens)++field :: forall (name :: Symbol) r a. HasField name r a => Lens' r a+field = lens (snd . f) (fst . f)+ where+ f :: r -> (a -> r, a)+ f = hasField @name
overloaded.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: overloaded-version: 0.1.1+version: 0.1.2 synopsis: Overloaded pragmas as a plugin description: Implement @Overloaded@ pragmas as a source plugin@@ -56,12 +56,13 @@ -- other dependencies build-depends:- , fin ^>=0.1- , 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+ , fin ^>=0.1+ , record-hasfield ^>=1.0+ , sop-core ^>=0.5.0.0+ , split ^>=0.2.3.3+ , syb ^>=0.7.1+ , symbols ^>=0.3.0.0+ , vec ^>=0.1.1.1 test-suite example default-language: Haskell2010@@ -85,6 +86,50 @@ , tasty , tasty-hunit +test-suite example-idiom-brackets+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ main-is: IdiomBrackets.hs++ -- inherited dependencies+ build-depends:+ , base+ , overloaded++ -- test dependencies+ build-depends:+ , HUnit ^>=1.6.0.0+ , tasty+ , tasty-hunit++test-suite example-record-fields+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: example+ main-is: RecordFields.hs++ -- inherited dependencies+ build-depends:+ , base+ , overloaded++ -- test dependencies+ build-depends:+ , HUnit ^>=1.6.0.0+ , record-hasfield+ , tasty+ , tasty-hunit++library optics-hasfield+ default-language: Haskell2010+ hs-source-dirs: optics-hasfield+ exposed-modules: Optics.HasField+ build-depends:+ , base+ , optics-core+ , record-hasfield+ test-suite test default-language: Haskell2010 type: exitcode-stdio-1.0@@ -98,6 +143,7 @@ Overloaded.Test.Lists Overloaded.Test.Naturals Overloaded.Test.Numerals+ Overloaded.Test.RecordFields Overloaded.Test.Strings Overloaded.Test.Symbols Overloaded.Test.TypeSymbols@@ -110,7 +156,10 @@ , bytestring , containers , fin+ , optics-core+ , optics-hasfield , overloaded+ , record-hasfield , sop-core , symbols , text
src/Overloaded.hs view
@@ -32,8 +32,11 @@ -- * Overloaded:TypeNats FromNatC (..), - -- * Overloade:TypeSymbols+ -- * Overloaded:TypeSymbols FromTypeSymbolC (..),++ -- * Overloaded:RecordFields+ -- | See "GHC.Records.Compat" from @record-hasfield@ package. ) where import Overloaded.Chars
src/Overloaded/Plugin.hs view
@@ -1,24 +1,34 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Overloaded plugin, which makes magic possible. module Overloaded.Plugin (plugin) where import Control.Applicative ((<|>))-import Control.Monad (foldM, when)+import Control.Monad (foldM, forM, guard, unless, when) import Control.Monad.IO.Class (MonadIO (..))-import Data.List (foldl', intercalate)+import Data.List (elemIndex, foldl', intercalate)+import Data.List.NonEmpty (NonEmpty (..)) import Data.List.Split (splitOn)-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Generics as SYB -- GHC stuff+import qualified Class import qualified ErrUtils as Err+import qualified FamInst+import qualified FamInstEnv import qualified Finder import qualified GhcPlugins as GHC-import HsSyn as GHC+import HsSyn as GHC import qualified IfaceEnv+import qualified RdrName import SrcLoc+import qualified TcEnv+import qualified TcEvidence as Tc+import qualified TcMType+import qualified TcPluginM as TC import qualified TcRnMonad as TcM import qualified TcRnTypes @@ -66,11 +76,82 @@ -- -- * Doesn't desugar inside patterns --+-- == RecordFields+--+-- __WARNING__ the type-checker plugin is experimental, it's adviced to use+--+-- @+-- {-\# OPTIONS_GHC -ddump-simpl #-}+-- @+--+-- to avoid surprising segfaults.+--+-- === Usage+--+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:RecordFields #-}+--+-- === Implementation bits+--+-- See Note [HasField instances] in "ClsInst", the behavior of this plugin is similar.+--+-- The 'GHC.Records.Compat.HasField' class is defined in "GHC.Records.Compat" module of @record-hasfield@ package:+--+-- @+-- class 'GHC.Records.Compat.HasField' {k} x r a | x r -> a where+-- 'GHC.Records.Compat.hasField' :: r -> (a -> r, a)+-- @+-- Suppose we have+--+-- @+-- data R y = MkR { foo :: [y] }+-- @+--+-- and @foo@ in scope. We will solve constraints like+--+-- @+-- HasField "foo" (R Int) a+-- @+--+-- by emitting a new wanted constraint+--+-- @+-- [Int] ~# a+-- @+--+-- and building a @HasField@ dictionary out of selector @foo@ appropriately cast.+--+-- == Idiom brackets from TemplateHaskellQuotes+--+-- @+-- {-\# LANGUAGE TemplateHaskellQuotes #-}+-- {-\# OPTIONS_GHC -fplugin=Overloaded -fplugin-opt=Overloaded:IdiomBrackets #-}+--+-- data Tree a+-- = Leaf a+-- | Branch (Tree a) (Tree a)+-- deriving (Show)+--+-- instance Functor Tree where+-- 'fmap' f (Leaf x) = Leaf (f x)+-- 'fmap' f (Branch l r) = Branch ('fmap' f l) ('fmap' f r)+--+-- instance Traversable Tree where+-- 'traverse' f (Leaf x) = [| Leaf (f x) |]+-- 'traverse' f (Branch l r) = [| Branch ('traverse' f l) ('traverse' f r) |]+-- @+-- plugin :: GHC.Plugin plugin = GHC.defaultPlugin { GHC.renamedResultAction = pluginImpl+ , GHC.tcPlugin = enabled tcPlugin , GHC.pluginRecompile = GHC.purePlugin }+ where+ enabled p args'+ | "RecordFields" `elem` args = Just p+ | otherwise = Nothing+ where+ args = concatMap (splitOn ":") args' pluginImpl :: [GHC.CommandLineOption]@@ -143,6 +224,10 @@ n <- lookupVarName dflags topEnv vn return $ transformLabels $ names { fromLabelName = n } + trBrackets <- case optIdiomBrackets of+ False -> return transformNoOp+ True -> return $ transformIdiomBrackets names+ trTypeNats <- case optTypeNats of Off -> return transformNoOp On Nothing -> return $ transformTypeNats names@@ -157,7 +242,7 @@ n <- lookupTypeName dflags topEnv vn return $ transformTypeSymbols $ names { fromTypeSymbolName = n } - let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel+ let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel /\ trBrackets let trT = trTypeNats /\ trTypeSymbols gr' <- transformType dflags trT gr@@ -176,7 +261,7 @@ -- Args parsing ------------------------------------------------------------------------------- -parseArgs :: GHC.DynFlags -> [String] -> TcRnTypes.TcM Options+parseArgs :: forall m. MonadIO m => GHC.DynFlags -> [String] -> m Options parseArgs dflags = foldM go0 defaultOptions where go0 opts arg = do (arg', vns) <- elaborateArg arg@@ -236,6 +321,10 @@ go opts "TypeSymbols" vns = do mvn <- oneName "TypeSymbols" vns return $ opts { optTypeSymbols = On mvn }+ go opts "RecordFields" _ =+ return $ opts { optRecordFields = True }+ go opts "IdiomBrackets" _ =+ return $ opts { optIdiomBrackets = True } go opts s _ = do warn dflags noSrcSpan $ GHC.text $ "Unknown Overloaded option " ++ show s@@ -258,41 +347,45 @@ warn dflags noSrcSpan $ GHC.text $ "Over two names specified for " ++ arg return (Just (V2 x y)) - elaborateArg :: String -> TcRnTypes.TcM (String, [VarName])+ elaborateArg :: String -> m (String, [VarName]) elaborateArg s = case splitOn "=" s of [] -> return ("", []) (pfx:xs) -> do vns <- traverse parseVarName xs return (pfx, catMaybes vns) - parseVarName :: String -> TcRnTypes.TcM (Maybe VarName)+ parseVarName :: String -> m (Maybe VarName) parseVarName "" = return Nothing parseVarName xs = do let ps = splitOn "." xs return (Just (VN (intercalate "." $ init ps) (last ps))) data Options = Options- { optStrings :: StrSym- , optNumerals :: NumNat- , optChars :: OnOff VarName- , optLists :: OnOff (V2 VarName)- , optIf :: OnOff VarName- , optLabels :: OnOff VarName- , optTypeNats :: OnOff VarName- , optTypeSymbols :: OnOff VarName+ { optStrings :: StrSym+ , optNumerals :: NumNat+ , optChars :: OnOff VarName+ , optLists :: OnOff (V2 VarName)+ , optIf :: OnOff VarName+ , optLabels :: OnOff VarName+ , optTypeNats :: OnOff VarName+ , optTypeSymbols :: OnOff VarName+ , optRecordFields :: Bool+ , optIdiomBrackets :: Bool } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options- { optStrings = NoStr- , optNumerals = NoNum- , optChars = Off- , optLists = Off- , optIf = Off- , optLabels = Off- , optTypeNats = Off- , optTypeSymbols = Off+ { optStrings = NoStr+ , optNumerals = NoNum+ , optChars = Off+ , optLists = Off+ , optIf = Off+ , optLabels = Off+ , optTypeNats = Off+ , optTypeSymbols = Off+ , optRecordFields = False+ , optIdiomBrackets = False } data StrSym@@ -456,7 +549,7 @@ -> TcRnTypes.TcM (HsGroup GhcRn) transform _dflags f = SYB.everywhereM (SYB.mkM transform') where transform' :: LHsExpr GhcRn -> TcRnTypes.TcM (LHsExpr GhcRn)- transform' e = do+ transform' e = return $ case f e of Just e' -> e' Nothing -> e@@ -526,6 +619,15 @@ overloadedTypeSymbolsMN :: GHC.ModuleName overloadedTypeSymbolsMN = GHC.mkModuleName "Overloaded.TypeSymbols" +ghcRecordsCompatMN :: GHC.ModuleName+ghcRecordsCompatMN = GHC.mkModuleName "GHC.Records.Compat"++ghcBaseMN :: GHC.ModuleName+ghcBaseMN = GHC.mkModuleName "GHC.Base"++dataFunctorMN :: GHC.ModuleName+dataFunctorMN = GHC.mkModuleName "Data.Functor"+ ------------------------------------------------------------------------------- -- Names -------------------------------------------------------------------------------@@ -542,6 +644,11 @@ , fromLabelName :: GHC.Name , fromTypeNatName :: GHC.Name , fromTypeSymbolName :: GHC.Name+ , fmapName :: GHC.Name+ , pureName :: GHC.Name+ , apName :: GHC.Name+ , birdName :: GHC.Name+ , voidName :: GHC.Name } getNames :: GHC.DynFlags -> GHC.HscEnv -> TcRnTypes.TcM Names@@ -559,6 +666,12 @@ fromTypeNatName <- lookupName' dflags env overloadedTypeNatsMN "FromNat" fromTypeSymbolName <- lookupName' dflags env overloadedTypeSymbolsMN "FromTypeSymbol" + fmapName <- lookupName dflags env ghcBaseMN "fmap"+ pureName <- lookupName dflags env ghcBaseMN "pure"+ apName <- lookupName dflags env ghcBaseMN "<*>"+ birdName <- lookupName dflags env ghcBaseMN "<*"+ voidName <- lookupName dflags env dataFunctorMN "void"+ return Names {..} lookupName :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> TcM.TcM GHC.Name@@ -607,8 +720,294 @@ debug _ = pure () ---------------------------------------------------------------------------------- V2+-- V2 and V4 ------------------------------------------------------------------------------- data V2 a = V2 a a deriving (Eq, Show)++data V4 a = V4 a a a a+ deriving (Eq, Show)++-------------------------------------------------------------------------------+-- Idioms brackets+-------------------------------------------------------------------------------++transformIdiomBrackets+ :: Names+ -> LHsExpr GhcRn+ -> Maybe (LHsExpr GhcRn)+transformIdiomBrackets names (L _l (HsRnBracketOut _ (ExpBr _ e) _))+ = Just (transformIdiomBrackets' names e)+transformIdiomBrackets _ _ = Nothing++transformIdiomBrackets'+ :: Names+ -> LHsExpr GhcRn+ -> LHsExpr GhcRn+transformIdiomBrackets' names expr@(L _e OpApp {}) = do+ let bt = matchOp expr+ let result = idiomBT names bt+ result+transformIdiomBrackets' names expr = do+ let (f :| args) = matchApp expr+ let f' = pureExpr names f+ let result = foldl' (applyExpr names) f' args+ result++-------------------------------------------------------------------------------+-- Function application maching+-------------------------------------------------------------------------------++-- | Match nested function applications, 'HsApp':+-- f x y z ~> f :| [x,y,z]+--+matchApp :: LHsExpr p -> NonEmpty (LHsExpr p)+matchApp (L _ (HsApp _ f x)) = neSnoc (matchApp f) x+matchApp e = pure e++neSnoc :: NonEmpty a -> a -> NonEmpty a+neSnoc (x :| xs) y = x :| xs ++ [y]++-------------------------------------------------------------------------------+-- Operator application matching+-------------------------------------------------------------------------------++-- | Match nested operator applications, 'OpApp'.+-- x + y * z ~> Branch (+) (Leaf x) (Branch (*) (Leaf y) (Leaf z))+matchOp :: LHsExpr p -> BT (LHsExpr p)+matchOp (L _ (OpApp _ lhs op rhs)) = Branch (matchOp lhs) op (matchOp rhs)+matchOp x = Leaf x++-- | Non-empty binary tree, with elements at branches too.+data BT a = Leaf a | Branch (BT a) a (BT a)++-- flatten: note that leaf is returned as is.+idiomBT :: Names -> BT (LHsExpr GhcRn) -> LHsExpr GhcRn+idiomBT _ (Leaf x) = x+idiomBT names (Branch lhs op rhs) = fmapExpr names op (idiomBT names lhs) `ap` idiomBT names rhs+ where+ ap = apExpr names++-------------------------------------------------------------------------------+-- Idioms related constructors+-------------------------------------------------------------------------------++applyExpr :: Names -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn+applyExpr names f (L _ (HsPar _ (L _ (HsApp _ (L _ (HsVar _ (L _ voidName'))) x))))+ | voidName' == voidName names = birdExpr names f x+applyExpr names f x = apExpr names f x++apExpr :: Names -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn+apExpr Names {..} f x = hsApps l' (hsVar l' apName) [f, x] where+ l' = GHC.noSrcSpan++birdExpr :: Names -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn+birdExpr Names {..} f x = hsApps l' (hsVar l' birdName) [f, x] where+ l' = GHC.noSrcSpan++fmapExpr :: Names -> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn+fmapExpr Names {..} f x = hsApps l' (hsVar l' fmapName) [f, x] where+ l' = GHC.noSrcSpan++pureExpr :: Names -> LHsExpr GhcRn -> LHsExpr GhcRn+pureExpr Names {..} x = hsApps l' (hsVar l' pureName) [x] where+ l' = GHC.noSrcSpan++-------------------------------------------------------------------------------+-- Type-checker plugin+-------------------------------------------------------------------------------++newtype PluginCtx = PluginCtx+ { hasPolyFieldCls :: Class.Class+ }++tcPlugin :: TcM.TcPlugin+tcPlugin = TcM.TcPlugin+ { TcM.tcPluginInit = tcPluginInit+ , TcM.tcPluginSolve = tcPluginSolve+ , TcM.tcPluginStop = const (return ())+ }++tcPluginInit :: TC.TcPluginM PluginCtx+tcPluginInit = do+ -- TODO: don't fail+ res <- TC.findImportedModule ghcRecordsCompatMN Nothing+ cls <- case res of+ GHC.Found _ md -> TC.tcLookupClass =<< TC.lookupOrig md (GHC.mkTcOcc "HasField")+ _ -> do+ dflags <- TC.unsafeTcPluginTcM GHC.getDynFlags+ TC.tcPluginIO $ GHC.putLogMsg dflags GHC.NoReason Err.SevError noSrcSpan (GHC.defaultErrStyle dflags) $+ GHC.text "Cannot find module" GHC.<+> GHC.ppr ghcRecordsCompatMN+ fail "panic!"++ return PluginCtx+ { hasPolyFieldCls = cls+ }++-- HasPolyField "petName" Pet Pet [Char] [Char]+tcPluginSolve :: PluginCtx -> TcRnTypes.TcPluginSolver+tcPluginSolve PluginCtx {..} _ _ wanteds = do+ -- acquire context+ dflags <- TC.unsafeTcPluginTcM GHC.getDynFlags+ famInstEnvs <- TC.getFamInstEnvs+ rdrEnv <- TC.unsafeTcPluginTcM TcM.getGlobalRdrEnv++ solved <- forM wantedsHasPolyField $ \(ct, tys@(V4 _k _name _s a)) -> do+ -- TC.tcPluginIO $ warn dflags noSrcSpan $+ -- GHC.text "wanted" GHC.<+> GHC.ppr ct++ m <- TC.unsafeTcPluginTcM $ matchHasField dflags famInstEnvs rdrEnv tys+ fmap (\evTerm -> (evTerm, ct)) $ forM m $ \(tc, dc, args, fl, _sel_id) -> do+ -- get location+ let ctloc = TcM.ctLoc ct+ -- let l = GHC.RealSrcSpan $ TcM.ctLocSpan ctloc++ -- debug print+ -- TC.tcPluginIO $ warn dflags l $ GHC.text "DEBUG" GHC.$$ GHC.ppr dbg++ let s' = GHC.mkTyConApp tc args++ let (exist, theta, xs) = GHC.dataConInstSig dc args+ let fls = GHC.dataConFieldLabels dc+ unless (length xs == length fls) $ fail "|tys| /= |fls|"++ idx <- case elemIndex fl fls of+ Nothing -> fail "field selector not in dataCon"+ Just idx -> return idx++ -- variables we can bind to+ let exist' = exist+ let exist_ = map GHC.mkTyVarTy exist'++ theta' <- traverse (makeVar "dict") $ GHC.substTysWith exist exist_ theta+ xs' <- traverse (makeVar "x") $ GHC.substTysWith exist exist_ xs++ let a' = xs !! idx+ let b' = a'+ let t' = s'++ bName <- TC.unsafeTcPluginTcM $ TcM.newName (GHC.mkVarOcc "b")+ let bBndr = GHC.mkLocalId bName $ xs !! idx++ -- (\b -> DC b x1 x2, x0)+ let rhs = GHC.mkConApp (GHC.tupleDataCon GHC.Boxed 2)+ [ GHC.Type $ GHC.mkFunTy b' t'+ , GHC.Type a'+ , GHC.mkCoreLams [bBndr] $ GHC.mkConApp2 dc (args ++ exist_) $ theta' ++ replace idx bBndr xs'+ , GHC.Var $ xs' !! idx+ ]++ -- (a -> r, r)+ let caseType = GHC.mkTyConApp (GHC.tupleTyCon GHC.Boxed 2)+ [ GHC.mkFunTy b' t'+ , a'+ ]++ -- DC x0 x1 x2 -> (\b -> DC b x1 x2, x0)+ let caseBranch = (GHC.DataAlt dc, exist' ++ theta' ++ xs', rhs)++ -- TC.tcPluginIO $ warn dflags l $+ -- GHC.text "cases"+ -- GHC.$$+ -- GHC.ppr caseType+ -- GHC.$$+ -- GHC.ppr caseBranch+++ -- \s -> case s of DC x0 x1 x2 -> (\b -> DC b x1 x2, x0)+ sName <- TC.unsafeTcPluginTcM $ TcM.newName (GHC.mkVarOcc "s")+ let sBndr = GHC.mkLocalId sName s'+ let expr = GHC.mkCoreLams [sBndr] $ GHC.Case (GHC.Var sBndr) sBndr caseType [caseBranch]+ let evterm = makeEvidence4 hasPolyFieldCls expr tys++ -- wanteds+ ctEvidence <- TC.newWanted ctloc $ GHC.mkPrimEqPred a a'++ return (evterm, [ TcM.mkNonCanonical ctEvidence -- a ~ a'+ ])++ return $ TcRnTypes.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 -> TcRnTypes.TcPluginM GHC.Var+makeVar n ty = do+ name <- TC.unsafeTcPluginTcM $ TcM.newName (GHC.mkVarOcc n)+ return (GHC.mkLocalId name ty)++-------------------------------------------------------------------------------+-- Simple Ct operations+-------------------------------------------------------------------------------++findClassConstraint4 :: Class.Class -> TcM.Ct -> Maybe (TcM.Ct, V4 GHC.Type)+findClassConstraint4 cls ct = do+ (cls', [k, x, s, a]) <- GHC.getClassPredTys_maybe (TcM.ctPred ct)+ guard (cls' == cls)+ return (ct, V4 k x s a)++-- | Make newtype class evidence+makeEvidence4 :: Class.Class -> GHC.CoreExpr -> V4 GHC.Type -> Tc.EvTerm+makeEvidence4 cls e (V4 k x s a) = Tc.EvExpr appDc where+ tyCon = Class.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+-------------------------------------------------------------------------------++matchHasField+ :: GHC.DynFlags+ -> (FamInstEnv.FamInstEnv, FamInstEnv.FamInstEnv)+ -> RdrName.GlobalRdrEnv+ -> V4 GHC.Type+ -> TcM.TcM (Maybe (GHC.TyCon, GHC.DataCon, [GHC.Type], GHC.FieldLabel, GHC.Id))+matchHasField _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 (FamInst.tcLookupDataFamInst famInstEnvs tc args)+ -- x should be a field of r+ , Just fl <- GHC.lookupTyConFieldLabel xStr s_tc+ -- the field selector should be in scope+ , Just _gre <- RdrName.lookupGRE_FieldLabel rdrEnv fl+ -- and the type should have only single data constructor (for simplicity)+ , Just [dc] <- GHC.tyConDataCons_maybe tc+ = do+ sel_id <- TcEnv.tcLookupId (GHC.flSelector fl)+ (_tv_prs, _preds, sel_ty) <- TcMType.tcInstType TcMType.newMetaTyVars sel_id++ -- The selector must not be "naughty" (i.e. the field+ -- cannot have an existentially quantified type), and+ -- it must not be higher-rank.+ if not (GHC.isNaughtyRecordSelector sel_id) && GHC.isTauTy sel_ty+ then return $ Just (tc, dc, args, fl, sel_id)+ else return Nothing++matchHasField _ _ _ _ = return Nothing++-------------------------------------------------------------------------------+-- Utils+-------------------------------------------------------------------------------++fstOf3 :: (a, b, c) -> a+fstOf3 (a, _, _) = a
+ test/Overloaded/Test/RecordFields.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedLabels #-}+{-# OPTIONS+ -fplugin=Overloaded+ -fplugin-opt=Overloaded:RecordFields:Labels=Optics.HasField.field+ #-}+module Overloaded.Test.RecordFields where++import Optics.Core (over, view)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests = testGroup "Strings"+ [ testCase "view" $+ view #petName bob @?= "bob"+ , testCase "over" $+ over #petAge succ bob @?= bob { petAge = 4 }+ ]++data Pet u = MkPet+ { petName :: String+ , petAge :: Int+ , petExtra :: u+ }+ deriving (Eq, Show)++bob :: Pet ()+bob = MkPet "bob" 3 ()