diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/example/Example.hs b/example/Example.hs --- a/example/Example.hs +++ b/example/Example.hs @@ -108,4 +108,3 @@ (if True then 'x' else 'y') @?= ('x' :: Char) (if Just 'b' then 'x' else 'y') @?= ('x' :: Char) - diff --git a/example/IdiomBrackets.hs b/example/IdiomBrackets.hs new file mode 100644 --- /dev/null +++ b/example/IdiomBrackets.hs @@ -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 diff --git a/example/RecordFields.hs b/example/RecordFields.hs new file mode 100644 --- /dev/null +++ b/example/RecordFields.hs @@ -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) diff --git a/optics-hasfield/Optics/HasField.hs b/optics-hasfield/Optics/HasField.hs new file mode 100644 --- /dev/null +++ b/optics-hasfield/Optics/HasField.hs @@ -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 diff --git a/overloaded.cabal b/overloaded.cabal --- a/overloaded.cabal +++ b/overloaded.cabal @@ -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 diff --git a/src/Overloaded.hs b/src/Overloaded.hs --- a/src/Overloaded.hs +++ b/src/Overloaded.hs @@ -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 diff --git a/src/Overloaded/Plugin.hs b/src/Overloaded/Plugin.hs --- a/src/Overloaded/Plugin.hs +++ b/src/Overloaded/Plugin.hs @@ -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 diff --git a/test/Overloaded/Test/RecordFields.hs b/test/Overloaded/Test/RecordFields.hs new file mode 100644 --- /dev/null +++ b/test/Overloaded/Test/RecordFields.hs @@ -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 ()