ghc-justdoit 0.1.0.1 → 0.1.0.2
raw patch · 6 files changed
+45/−55 lines, 6 filesdep ~basedep ~ghc
Dependency ranges changed: base, ghc
Files
- ChangeLog.md +4/−0
- GHC/JustDoIt/Plugin.hs +9/−14
- GHC/JustDoIt/Solver.hs +2/−3
- GHC/LJT.hs +25/−34
- README.md +1/−0
- ghc-justdoit.cabal +4/−4
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for ghc-justdoit +## 0.1.0.2 -- 2012-08-01++* Compatibility with ghc-9.0, dropping support for older GHCs+ ## 0.1.0.1 -- 2018-10-11 * Compatibility with ghc-8.6 as released
GHC/JustDoIt/Plugin.hs view
@@ -1,24 +1,19 @@ {-# LANGUAGE CPP, TupleSections #-}-module GHC.JustDoIt.Plugin ( plugin )-where+module GHC.JustDoIt.Plugin ( plugin ) where -- external import Data.Maybe import Control.Monad -- GHC API-import Module (mkModuleName)-import OccName (mkTcOcc)-import Plugins (Plugin (..), defaultPlugin)-import TcEvidence-import TcPluginM-import TcRnTypes-import Class-import CoreUtils-import MkCore-import TyCon-import Type-import CoreSyn+import GHC.Unit.Module.Name (mkModuleName)+import GHC.Plugins hiding (TcPlugin)+import GHC.Tc.Types+import GHC.Tc.Types.Constraint+import GHC.Tc.Plugin+import GHC.Core.Class+import GHC.Tc.Types.Evidence+import GHC.Core.Predicate import GHC.JustDoIt.Solver
GHC/JustDoIt/Solver.hs view
@@ -1,11 +1,10 @@ module GHC.JustDoIt.Solver ( solve ) where -import Type-import CoreSyn+import Data.Maybe+import GHC.Plugins import GHC.LJT -import Data.Maybe -- | Central place to plug additional solvers in. For now, we just do "GHC.LJT" solve :: Type -> Maybe CoreExpr
GHC/LJT.hs view
@@ -1,24 +1,10 @@ -- | An implementation of LJT proof search directly on Core terms. module GHC.LJT where -import FastString-import Unique-import Type-import Id-import Var-import CoreSyn-import Outputable-import TyCoRep-import TyCon-import DataCon-import MkCore-import MkId-import CoreUtils-import TysWiredIn-import BasicTypes-import NameEnv-import NameSet-import Coercion+import GHC.Plugins+import GHC.Core.TyCo.Rep+import GHC.Types.Id.Make+import GHC.Types.Unique import Data.List import Data.Hashable@@ -40,7 +26,7 @@ -- Rule f⇒ ante ==> goal | Just v <- find (\v -> isEmptyTy (idType v)) ante- = pure $ mkWildCase (Var v) (idType v) goal []+ = pure $ mkWildCase (Var v) (unrestricted (idType v)) goal [] -- Rule →⇒2 ante ==> goal@@ -74,7 +60,7 @@ destruct (Var vAorB) vs <$> sequence [ (v:ante') ==> goal | v <- vs] -- Rule ⇒→-ante ==> FunTy t1 t2+ante ==> FunTy _af _mult t1 t2 = Lam v <$> (v : ante) ==> t2 where v = newVar t1@@ -96,7 +82,7 @@ | Just ((vABC, ((a,b),_)), ante') <- anyA (funLeft (funLeft Just)) ante = do let eBC = lam b $ \vB -> App (Var vABC) (lam a $ \_ -> Var vB)- eAB <- letA eBC $ \vBC -> (vBC : ante') ==> FunTy a b+ eAB <- letA eBC $ \vBC -> (vBC : ante') ==> FunTy VisArg Many a b letA (App (Var vABC) eAB) $ \vC -> (vC : ante') ==> goal -- Nothing found :-(@@ -107,7 +93,7 @@ -- Smart constructors newVar :: Type -> Id-newVar ty = mkSysLocal (mkFastString "x") (mkBuiltinUnique i) ty+newVar ty = mkSysLocal (mkFastString "x") (mkBuiltinUnique i) Many ty where i = hash (showSDocUnsafe (ppr ty)) -- We don’t mind if variables with equal types shadow each other, -- so let’s just derive the unique from the type@@ -136,16 +122,17 @@ isProdType :: Type -> Maybe ([Type], [CoreExpr] -> CoreExpr, CoreExpr -> [Id] -> CoreExpr -> CoreExpr) isProdType ty- | Just (tc, _, dc, repargs) <- splitDataProductType_maybe ty+ | Just (tc, _, dc, repargs') <- splitDataProductType_maybe ty+ , let repargs = map scaledThing repargs' , not (isRecTyCon tc) = Just ( repargs , \args -> mkConApp dc (map Type repargs ++ args)- , \scrut pats rhs -> mkWildCase scrut ty (exprType rhs) [(DataAlt dc, pats, rhs)]+ , \scrut pats rhs -> mkWildCase scrut (unrestricted ty) (exprType rhs) [(DataAlt dc, pats, rhs)] ) | Just (tc, ty_args) <- splitTyConApp_maybe ty , Just dc <- newTyConDataCon_maybe tc , not (isRecTyCon tc)- , let repargs = dataConInstArgTys dc ty_args+ , let repargs = map scaledThing $ dataConInstArgTys dc ty_args = Just ( repargs , \[arg] -> wrapNewTypeBody tc ty_args arg , \scrut [pat] rhs ->@@ -160,17 +147,17 @@ | Just (tc, ty_args) <- splitTyConApp_maybe ty , Just dcs <- isDataSumTyCon_maybe tc , not (isRecTyCon tc)- = let tys = [ mkTupleTy Boxed (dataConInstArgTys dc ty_args) | dc <- dcs ]+ = let tys = [ mkTupleTy Boxed (map scaledThing (dataConInstArgTys dc ty_args)) | dc <- dcs ] injs = [ let vtys = dataConInstArgTys dc ty_args- vs = map newVar vtys+ vs = map (newVar . scaledThing) vtys in \ e -> mkSmallTupleCase vs (mkConApp dc (map Type ty_args ++ map Var vs))- (mkWildValBinder (exprType e)) e+ (mkWildValBinder Many (exprType e)) e | dc <- dcs] destruct = \e vs alts ->- Case e (mkWildValBinder (exprType e)) (exprType (head alts)) - [ let pats = map newVar (dataConInstArgTys dc ty_args) in- (DataAlt dc, pats, mkLetNonRec v (mkCoreVarTup pats) rhs)+ Case e (mkWildValBinder Many (exprType e)) (exprType (head alts))+ [ let pats = map (newVar . scaledThing) (dataConInstArgTys dc ty_args) in+ (DataAlt dc, pats, mkLetNonRec v (mkCoreTup (map Var pats)) rhs) | (dc,v,rhs) <- zip3 dcs vs alts ] in Just (tys, injs, destruct) isSumType _ = Nothing@@ -188,7 +175,11 @@ | any isHigherKind paramKinds = False | any (go seen') mentionedTyCons = True | otherwise = False- where mentionedTyCons = concatMap getTyCons $ concatMap dataConOrigArgTys $ tyConDataCons tc+ where mentionedTyCons =+ concatMap getTyCons $+ map scaledThing $+ concatMap dataConOrigArgTys $+ tyConDataCons tc paramKinds = map varType (tyConTyVars tc) seen' = seen `extendNameSet` tyConName tc @@ -202,7 +193,7 @@ go (LitTy _) = emptyNameEnv go (TyVarTy _) = emptyNameEnv go (AppTy a b) = go a `plusNameEnv` go b- go (FunTy a b) = go a `plusNameEnv` go b+ go (FunTy _ _ a b) = go a `plusNameEnv` go b go (ForAllTy _ ty) = go ty go (CastTy ty _) = go ty go (CoercionTy co) = emptyNameEnv@@ -221,7 +212,7 @@ -- Combinators to search for matching things funLeft :: (Type -> Maybe a) -> Type -> Maybe (a,Type)-funLeft p (FunTy t1 t2) = (\x -> (x,t2)) <$> p t1+funLeft p (FunTy _af _mult t1 t2) = (\x -> (x,t2)) <$> p t1 funLeft _ _ = Nothing anyA :: (Type -> Maybe a) -> [Id] -> Maybe ((Id, a), [Id])
README.md view
@@ -22,6 +22,7 @@ * The implementation is very much unoptimized. * It returns one solution, but not necessary the “best” one. But what is the “best” one? * It ignores any recursive type, so it cannot do anything with lists. It would be much more useful if it could do some best-effort thing here as well.+ * It ignores linear types, and will likely produce ill-typed expressions for them. If someone wants to pick it up from here, that’d be great!
ghc-justdoit.cabal view
@@ -1,5 +1,5 @@ name: ghc-justdoit-version: 0.1.0.1+version: 0.1.0.2 synopsis: A magic typeclass that just does it description: This plugin allows you to write@@ -29,16 +29,16 @@ build-type: Simple extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10-tested-with: GHC ==8.6.*, GHC ==8.7.*+tested-with: GHC ==9.0.* library exposed-modules: GHC.LJT exposed-modules: GHC.JustDoIt exposed-modules: GHC.JustDoIt.Plugin exposed-modules: GHC.JustDoIt.Solver- build-depends: base >=4.11 && <4.14+ build-depends: base >=4.15 && <4.16 build-depends: hashable- build-depends: ghc >=8.5+ build-depends: ghc >=9.0 default-language: Haskell2010 test-suite demo