├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── ChangeLog.md ├── GHC ├── JustDoIt.hs ├── JustDoIt │ ├── Plugin.hs │ └── Solver.hs └── LJT.hs ├── LICENSE ├── README.md ├── Setup.hs ├── examples └── Demo.hs └── ghc-justdoit.cabal /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--last-in-series' 'ghc-justdoit.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.14.1 12 | # 13 | # REGENDATA ("0.14.1",["github","--last-in-series","ghc-justdoit.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-18.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.0.2 32 | compilerKind: ghc 33 | compilerVersion: 9.0.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | fail-fast: false 37 | steps: 38 | - name: apt 39 | run: | 40 | apt-get update 41 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 42 | mkdir -p "$HOME/.ghcup/bin" 43 | curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup" 44 | chmod a+x "$HOME/.ghcup/bin/ghcup" 45 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" 46 | "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 47 | env: 48 | HCKIND: ${{ matrix.compilerKind }} 49 | HCNAME: ${{ matrix.compiler }} 50 | HCVER: ${{ matrix.compilerVersion }} 51 | - name: Set PATH and environment variables 52 | run: | 53 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 54 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 55 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 56 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 57 | HCDIR=/opt/$HCKIND/$HCVER 58 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 59 | echo "HC=$HC" >> "$GITHUB_ENV" 60 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 61 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 62 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 63 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 64 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 65 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 66 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 67 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 68 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 69 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 70 | env: 71 | HCKIND: ${{ matrix.compilerKind }} 72 | HCNAME: ${{ matrix.compiler }} 73 | HCVER: ${{ matrix.compilerVersion }} 74 | - name: env 75 | run: | 76 | env 77 | - name: write cabal config 78 | run: | 79 | mkdir -p $CABAL_DIR 80 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 113 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 114 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 115 | rm -f cabal-plan.xz 116 | chmod a+x $HOME/.cabal/bin/cabal-plan 117 | cabal-plan --version 118 | - name: checkout 119 | uses: actions/checkout@v2 120 | with: 121 | path: source 122 | - name: initial cabal.project for sdist 123 | run: | 124 | touch cabal.project 125 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 126 | cat cabal.project 127 | - name: sdist 128 | run: | 129 | mkdir -p sdist 130 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 131 | - name: unpack 132 | run: | 133 | mkdir -p unpacked 134 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 135 | - name: generate cabal.project 136 | run: | 137 | PKGDIR_ghc_justdoit="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/ghc-justdoit-[0-9.]*')" 138 | echo "PKGDIR_ghc_justdoit=${PKGDIR_ghc_justdoit}" >> "$GITHUB_ENV" 139 | rm -f cabal.project cabal.project.local 140 | touch cabal.project 141 | touch cabal.project.local 142 | echo "packages: ${PKGDIR_ghc_justdoit}" >> cabal.project 143 | echo "package ghc-justdoit" >> cabal.project 144 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 145 | cat >> cabal.project <> cabal.project.local 148 | cat cabal.project 149 | cat cabal.project.local 150 | - name: dump install plan 151 | run: | 152 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 153 | cabal-plan 154 | - name: cache 155 | uses: actions/cache@v2 156 | with: 157 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 158 | path: ~/.cabal/store 159 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 160 | - name: install dependencies 161 | run: | 162 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 163 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 164 | - name: build w/o tests 165 | run: | 166 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 167 | - name: build 168 | run: | 169 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 170 | - name: tests 171 | run: | 172 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 173 | - name: cabal check 174 | run: | 175 | cd ${PKGDIR_ghc_justdoit} || false 176 | ${CABAL} -vnormal check 177 | - name: haddock 178 | run: | 179 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 180 | - name: unconstrained build 181 | run: | 182 | rm -f cabal.project.local 183 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 184 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for ghc-justdoit 2 | 3 | ## 0.1.0.2 -- 2012-08-01 4 | 5 | * Compatibility with ghc-9.0, dropping support for older GHCs 6 | 7 | ## 0.1.0.1 -- 2018-10-11 8 | 9 | * Compatibility with ghc-8.6 as released 10 | 11 | ## 0.1 -- 2018-02-02 12 | 13 | * First version. Released on an unsuspecting world. 14 | -------------------------------------------------------------------------------- /GHC/JustDoIt.hs: -------------------------------------------------------------------------------- 1 | module GHC.JustDoIt ( JustDoIt, justDoIt, (…) ) where 2 | 3 | class JustDoIt a where justDoIt' :: a 4 | 5 | justDoIt :: JustDoIt a => a 6 | justDoIt = justDoIt' 7 | 8 | (…) :: JustDoIt a => a 9 | (…) = justDoIt' 10 | -------------------------------------------------------------------------------- /GHC/JustDoIt/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, TupleSections #-} 2 | module GHC.JustDoIt.Plugin ( plugin ) where 3 | 4 | -- external 5 | import Data.Maybe 6 | import Control.Monad 7 | 8 | -- GHC API 9 | import GHC.Unit.Module.Name (mkModuleName) 10 | import GHC.Plugins hiding (TcPlugin) 11 | import GHC.Tc.Types 12 | import GHC.Tc.Types.Constraint 13 | import GHC.Tc.Plugin 14 | import GHC.Core.Class 15 | import GHC.Tc.Types.Evidence 16 | import GHC.Core.Predicate 17 | 18 | import GHC.JustDoIt.Solver 19 | 20 | plugin :: Plugin 21 | plugin = defaultPlugin { tcPlugin = const (Just jdiPlugin) } 22 | 23 | jdiPlugin :: TcPlugin 24 | jdiPlugin = 25 | TcPlugin { tcPluginInit = lookupJDITyCon 26 | , tcPluginSolve = solveJDI 27 | , tcPluginStop = const (return ()) 28 | } 29 | 30 | lookupJDITyCon :: TcPluginM Class 31 | lookupJDITyCon = do 32 | Found _ md <- findImportedModule jdiModule Nothing 33 | jdiTcNm <- lookupOrig md (mkTcOcc "JustDoIt") 34 | tcLookupClass jdiTcNm 35 | where 36 | jdiModule = mkModuleName "GHC.JustDoIt" 37 | 38 | wrap :: Class -> CoreExpr -> EvTerm 39 | wrap cls = EvExpr . appDc 40 | where 41 | tyCon = classTyCon cls 42 | dc = tyConSingleDataCon tyCon 43 | appDc x = mkCoreConApps dc [Type (exprType x), x] 44 | 45 | findClassConstraint :: Class -> Ct -> Maybe (Ct, Type) 46 | findClassConstraint cls ct = do 47 | (cls', [t]) <- getClassPredTys_maybe (ctPred ct) 48 | guard (cls' == cls) 49 | return (ct, t) 50 | 51 | solveJDI :: Class -- ^ JDI's TyCon 52 | -> [Ct] -- ^ [G]iven constraints 53 | -> [Ct] -- ^ [D]erived constraints 54 | -> [Ct] -- ^ [W]anted constraints 55 | -> TcPluginM TcPluginResult 56 | solveJDI jdiCls _ _ wanteds = 57 | return $! case result of 58 | Left x -> TcPluginContradiction [x] 59 | Right solved -> TcPluginOk solved [] 60 | where 61 | our_wanteds = mapMaybe (findClassConstraint jdiCls) wanteds 62 | result = partitionMaybe (fmap (wrap jdiCls) . solve) our_wanteds 63 | 64 | partitionMaybe :: (b -> Maybe c) -> [(a,b)] -> Either a [(c,a)] 65 | partitionMaybe _ [] = Right [] 66 | partitionMaybe f ((k,v):xs) = case f v of 67 | Nothing -> Left k 68 | Just y -> ((y,k):) <$> partitionMaybe f xs 69 | -------------------------------------------------------------------------------- /GHC/JustDoIt/Solver.hs: -------------------------------------------------------------------------------- 1 | module GHC.JustDoIt.Solver ( solve ) where 2 | 3 | import Data.Maybe 4 | import GHC.Plugins 5 | 6 | import GHC.LJT 7 | 8 | 9 | -- | Central place to plug additional solvers in. For now, we just do "GHC.LJT" 10 | solve :: Type -> Maybe CoreExpr 11 | solve = listToMaybe . ljt 12 | -------------------------------------------------------------------------------- /GHC/LJT.hs: -------------------------------------------------------------------------------- 1 | -- | An implementation of LJT proof search directly on Core terms. 2 | module GHC.LJT where 3 | 4 | import GHC.Plugins 5 | import GHC.Core.TyCo.Rep 6 | import GHC.Types.Id.Make 7 | import GHC.Types.Unique 8 | 9 | import Data.List 10 | import Data.Hashable 11 | import Control.Monad 12 | import Data.Bifunctor 13 | 14 | ljt :: Type -> [CoreExpr] 15 | ljt t = [] ==> t 16 | 17 | 18 | (==>) :: [Id] -> Type -> [CoreExpr] 19 | 20 | -- Rule Axiom 21 | -- (TODO: The official algorithm restricts this rule to atoms. Why?) 22 | ante ==> goal 23 | | Just v <- find (\v -> idType v `eqType` goal) ante 24 | = pure $ Var v 25 | 26 | -- Rule f⇒ 27 | ante ==> goal 28 | | Just v <- find (\v -> isEmptyTy (idType v)) ante 29 | = pure $ mkWildCase (Var v) (unrestricted (idType v)) goal [] 30 | 31 | -- Rule →⇒2 32 | ante ==> goal 33 | | Just ((v,((tys, build, _destruct),_r)),ante') <- anyA (funLeft isProdType) ante 34 | = let vs = map newVar tys 35 | expr = mkLams vs (App (Var v) (build (map Var vs))) 36 | v' = newVar (exprType expr) 37 | in mkLetNonRec v' expr <$> (v' : ante') ==> goal 38 | 39 | -- Rule →⇒3 40 | ante ==> goal 41 | | Just ((v,((tys, injs, _destruct),_r)),ante') <- anyA (funLeft isSumType) ante 42 | = let es = [ lam ty (\vx -> App (Var v) (inj (Var vx))) | (ty,inj) <- zip tys injs ] 43 | in letsA es $ \vs -> (vs ++ ante') ==> goal 44 | 45 | -- Rule ∧⇒ 46 | ante ==> goal 47 | | Just ((v,(tys, _build, destruct)),ante') <- anyA isProdType ante 48 | = let pats = map newVar tys 49 | in destruct (Var v) pats <$> (pats ++ ante') ==> goal 50 | 51 | -- Rule ⇒∧ 52 | ante ==> goal 53 | | Just (tys, build, _destruct) <- isProdType goal 54 | = build <$> sequence [ante ==> ty | ty <- tys] 55 | 56 | -- Rule ∨⇒ 57 | ante ==> goal 58 | | Just ((vAorB, (tys, _injs, destruct)),ante') <- anyA isSumType ante 59 | = let vs = map newVar tys in 60 | destruct (Var vAorB) vs <$> sequence [ (v:ante') ==> goal | v <- vs] 61 | 62 | -- Rule ⇒→ 63 | ante ==> FunTy _af _mult t1 t2 64 | = Lam v <$> (v : ante) ==> t2 65 | where 66 | v = newVar t1 67 | 68 | -- Rule →⇒1 69 | -- (TODO: The official algorithm restricts this rule to atoms. Why?) 70 | ante ==> goal 71 | | let isInAnte a = find (\v -> idType v `eqType` a) ante 72 | , Just ((vAB, (vA,_)), ante') <- anyA (funLeft isInAnte) ante 73 | = letA (App (Var vAB) (Var vA)) $ \vB -> (vB : ante') ==> goal 74 | 75 | -- Rule ⇒∨ 76 | ante ==> goal 77 | | Just (tys, injs, _destruct) <- isSumType goal 78 | = msum [ inj <$> ante ==> ty | (ty,inj) <- zip tys injs ] 79 | 80 | -- Rule →⇒4 81 | ante ==> goal 82 | | Just ((vABC, ((a,b),_)), ante') <- anyA (funLeft (funLeft Just)) ante 83 | = do 84 | let eBC = lam b $ \vB -> App (Var vABC) (lam a $ \_ -> Var vB) 85 | eAB <- letA eBC $ \vBC -> (vBC : ante') ==> FunTy VisArg Many a b 86 | letA (App (Var vABC) eAB) $ \vC -> (vC : ante') ==> goal 87 | 88 | -- Nothing found :-( 89 | _ante ==> _goal 90 | = -- pprTrace "go" (vcat [ ppr (idType v) | v <- ante] $$ text "------" $$ ppr goal) $ 91 | mzero 92 | 93 | -- Smart constructors 94 | 95 | newVar :: Type -> Id 96 | newVar ty = mkSysLocal (mkFastString "x") (mkBuiltinUnique i) Many ty 97 | where i = hash (showSDocUnsafe (ppr ty)) 98 | -- We don’t mind if variables with equal types shadow each other, 99 | -- so let’s just derive the unique from the type 100 | 101 | lam :: Type -> (Id -> CoreExpr) -> CoreExpr 102 | lam ty gen = Lam v $ gen v 103 | where v = newVar ty 104 | 105 | lamA :: Applicative f => Type -> (Id -> f CoreExpr) -> f CoreExpr 106 | lamA ty gen = Lam v <$> gen v 107 | where v = newVar ty 108 | 109 | let_ :: CoreExpr -> (Id -> CoreExpr) -> CoreExpr 110 | let_ e gen = mkLetNonRec v e $ gen v 111 | where v = newVar (exprType e) 112 | 113 | letA :: Applicative f => CoreExpr -> (Id -> f CoreExpr) -> f CoreExpr 114 | letA e gen = mkLetNonRec v e <$> gen v 115 | where v = newVar (exprType e) 116 | 117 | letsA :: Applicative f => [CoreExpr] -> ([Id] -> f CoreExpr) -> f CoreExpr 118 | letsA es gen = mkLets (zipWith NonRec vs es) <$> gen vs 119 | where vs = map (newVar . exprType) es 120 | 121 | -- Predicate on types 122 | 123 | isProdType :: Type -> Maybe ([Type], [CoreExpr] -> CoreExpr, CoreExpr -> [Id] -> CoreExpr -> CoreExpr) 124 | isProdType ty 125 | | Just (tc, _, dc, repargs') <- splitDataProductType_maybe ty 126 | , let repargs = map scaledThing repargs' 127 | , not (isRecTyCon tc) 128 | = Just ( repargs 129 | , \args -> mkConApp dc (map Type repargs ++ args) 130 | , \scrut pats rhs -> mkWildCase scrut (unrestricted ty) (exprType rhs) [(DataAlt dc, pats, rhs)] 131 | ) 132 | | Just (tc, ty_args) <- splitTyConApp_maybe ty 133 | , Just dc <- newTyConDataCon_maybe tc 134 | , not (isRecTyCon tc) 135 | , let repargs = map scaledThing $ dataConInstArgTys dc ty_args 136 | = Just ( repargs 137 | , \[arg] -> wrapNewTypeBody tc ty_args arg 138 | , \scrut [pat] rhs -> 139 | mkLetNonRec pat (unwrapNewTypeBody tc ty_args scrut) rhs 140 | ) 141 | isProdType _ = Nothing 142 | 143 | -- Haskell sum constructors can have multiple parameters. For our purposes, if 144 | -- so, we wrap them in a product. 145 | isSumType :: Type -> Maybe ([Type], [CoreExpr -> CoreExpr], CoreExpr -> [Id] -> [CoreExpr] -> CoreExpr) 146 | isSumType ty 147 | | Just (tc, ty_args) <- splitTyConApp_maybe ty 148 | , Just dcs <- isDataSumTyCon_maybe tc 149 | , not (isRecTyCon tc) 150 | = let tys = [ mkTupleTy Boxed (map scaledThing (dataConInstArgTys dc ty_args)) | dc <- dcs ] 151 | injs = [ 152 | let vtys = dataConInstArgTys dc ty_args 153 | vs = map (newVar . scaledThing) vtys 154 | in \ e -> mkSmallTupleCase vs (mkConApp dc (map Type ty_args ++ map Var vs)) 155 | (mkWildValBinder Many (exprType e)) e 156 | | dc <- dcs] 157 | destruct = \e vs alts -> 158 | Case e (mkWildValBinder Many (exprType e)) (exprType (head alts)) 159 | [ let pats = map (newVar . scaledThing) (dataConInstArgTys dc ty_args) in 160 | (DataAlt dc, pats, mkLetNonRec v (mkCoreTup (map Var pats)) rhs) 161 | | (dc,v,rhs) <- zip3 dcs vs alts ] 162 | in Just (tys, injs, destruct) 163 | isSumType _ = Nothing 164 | 165 | -- We don’t want to look into recursive type cons. 166 | -- Which ones are recursive? Surely those that get mentioned in their 167 | -- arguments. Or in type cons in their arguments. 168 | -- But that is not enough, because of higher kinded arguments. So prohibit 169 | -- those as well. 170 | 171 | isRecTyCon :: TyCon -> Bool 172 | isRecTyCon tc = go emptyNameSet tc 173 | where 174 | go seen tc | tyConName tc `elemNameSet` seen = True 175 | | any isHigherKind paramKinds = False 176 | | any (go seen') mentionedTyCons = True 177 | | otherwise = False 178 | where mentionedTyCons = 179 | concatMap getTyCons $ 180 | map scaledThing $ 181 | concatMap dataConOrigArgTys $ 182 | tyConDataCons tc 183 | paramKinds = map varType (tyConTyVars tc) 184 | seen' = seen `extendNameSet` tyConName tc 185 | 186 | isHigherKind :: Kind -> Bool 187 | isHigherKind k = not (k `eqType` liftedTypeKind) 188 | 189 | getTyCons :: Type -> [TyCon] 190 | getTyCons = nameEnvElts . go 191 | where 192 | go (TyConApp tc tys) = unitNameEnv (tyConName tc) tc `plusNameEnv` go_s tys 193 | go (LitTy _) = emptyNameEnv 194 | go (TyVarTy _) = emptyNameEnv 195 | go (AppTy a b) = go a `plusNameEnv` go b 196 | go (FunTy _ _ a b) = go a `plusNameEnv` go b 197 | go (ForAllTy _ ty) = go ty 198 | go (CastTy ty _) = go ty 199 | go (CoercionTy co) = emptyNameEnv 200 | go_s = foldr (plusNameEnv . go) emptyNameEnv 201 | 202 | 203 | 204 | -- A copy from MkId.hs, no longer exported there :-( 205 | wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr 206 | wrapNewTypeBody tycon args result_expr 207 | = wrapFamInstBody tycon args $ 208 | mkCast result_expr (mkSymCo co) 209 | where 210 | co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] 211 | 212 | -- Combinators to search for matching things 213 | 214 | funLeft :: (Type -> Maybe a) -> Type -> Maybe (a,Type) 215 | funLeft p (FunTy _af _mult t1 t2) = (\x -> (x,t2)) <$> p t1 216 | funLeft _ _ = Nothing 217 | 218 | anyA :: (Type -> Maybe a) -> [Id] -> Maybe ((Id, a), [Id]) 219 | anyA _ [] = Nothing 220 | anyA p (v:vs) | Just x <- p (idType v) = Just ((v,x), vs) 221 | | otherwise = second (v:) <$> anyA p vs 222 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Joachim Breitner 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ghc-justdoit: a GHC plugin to write the code for you 2 | ========================================= 3 | 4 | This is a prototype of a code synthesis plugin for GHC, which uses LJT proof 5 | search to instantiate a type. 6 | 7 | Synopsis 8 | -------- 9 | 10 | {-# OPTIONS_GHC -fplugin=GHC.JustDoIt.Plugin #-} 11 | module Test where 12 | 13 | import GHC.JustDoIt 14 | 15 | foo :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r) 16 | foo = (…) 17 | 18 | Missing bits 19 | ------------ 20 | 21 | * The LJT might not be complete, due to insufficient backtracking. 22 | * The implementation is very much unoptimized. 23 | * It returns one solution, but not necessary the “best” one. But what is the “best” one? 24 | * 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. 25 | * It ignores linear types, and will likely produce ill-typed expressions for them. 26 | 27 | If someone wants to pick it up from here, that’d be great! 28 | 29 | 30 | Related work 31 | ------------ 32 | 33 | * [Djinn](http://hackage.haskell.org/package/djinn) and [djinn-ghc](http://hackage.haskell.org/package/djinn-ghc) 34 | * [exference](http://hackage.haskell.org/package/exference) 35 | * [curryhoward](https://github.com/Chymyst/curryhoward) for Scala 36 | * [hezarfen](https://github.com/joom/hezarfen) for Idris 37 | 38 | Contact 39 | ------- 40 | 41 | Please reports bugs and missing features at the [GitHub bugtracker]. This is 42 | also where you can find the [source code]. 43 | 44 | `ghc-justdoit` was written by [Joachim Breitner] and is licensed under a 45 | permissive MIT [license]. 46 | 47 | [GitHub bugtracker]: https://github.com/nomeata/ghc-justdoit/issues 48 | [source code]: https://github.com/nomeata/ghc-justdoit 49 | [Joachim Breitner]: http://www.joachim-breitner.de/ 50 | [license]: https://github.com/nomeata/ghc-justdoit/blob/LICENSE 51 | 52 | 53 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Demo.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fplugin=GHC.JustDoIt.Plugin #-} 2 | {-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-} 3 | {-# LANGUAGE TemplateHaskell, LambdaCase, EmptyCase #-} 4 | import GHC.JustDoIt 5 | import Test.Inspection (inspect, (===), (==-)) 6 | 7 | import Prelude hiding (id, flip, const, curry) 8 | 9 | -- Some auxillary definitions 10 | 11 | data Unit = Unit 12 | data Void 13 | data MyLargeSum a b c d e = MkA a | MkB b | MkC c | MkD d | MkE e 14 | newtype Id a = Id a 15 | data Result a b = Failure a | Success b 16 | newtype ErrRead r e a = ErrRead { unErrRead :: r -> Result e a } 17 | 18 | -- All these functions have basically one sensible implementation. 19 | -- With GHC.JustDoIt, we don’t have to write them. 20 | 21 | id :: a -> a 22 | id = justDoIt 23 | 24 | const :: a -> b -> a 25 | const = (…) 26 | 27 | flip :: (a -> b -> c) -> (b -> a -> c) 28 | flip = (…) 29 | 30 | dup :: a -> (a,a) 31 | dup = (…) 32 | 33 | pair :: a -> b -> (a,b) 34 | pair = (…) 35 | 36 | tripl :: a -> b -> c -> (a,b,c) 37 | tripl = (…) 38 | 39 | proj :: (a,b,c,d) -> c 40 | proj = (…) 41 | 42 | curry :: ((a,b) -> c) -> a -> b -> c 43 | curry = (…) 44 | 45 | curryFlip :: ((a,b) -> c) -> b -> a -> c 46 | curryFlip = (…) 47 | 48 | contBind :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r) 49 | contBind = (…) 50 | 51 | contAp :: (((a -> b) -> r) -> r) -> ((a -> r) -> r) -> ((b -> r) -> r) 52 | contAp = (…) 53 | 54 | errReadBind :: (r -> Either e a) -> (a -> (r -> Either e b)) -> (r -> Either e b) 55 | errReadBind = (…) 56 | 57 | errReadBindTup :: (r -> Either e a) -> (a -> (r -> Either e b)) -> (r -> Either e (a,b)) 58 | errReadBindTup = (…) 59 | 60 | errReadAp :: (r -> Either e (a -> b)) -> (r -> Either e a) -> (r -> Either e b) 61 | errReadAp = (…) 62 | 63 | errReadBindTup2 :: ErrRead r e a -> (a -> ErrRead r e b) -> ErrRead r e (a,b) 64 | errReadBindTup2 = (…) 65 | 66 | unit :: Unit 67 | unit = (…) 68 | 69 | swapEither :: Either a b -> Either b a 70 | swapEither = (…) 71 | 72 | swapEitherCont :: (((Either a b) -> r) -> r) -> (((Either b a) -> r) -> r) 73 | swapEitherCont = (…) 74 | 75 | randomCrap :: (a -> b) -> (a,c,d) -> (d,b,b) 76 | randomCrap = (…) 77 | 78 | absurd :: Void -> a 79 | absurd = (…) 80 | 81 | convert :: MyLargeSum a b c d e -> Either a (Either b (Either c (Either d e))) 82 | convert = (…) 83 | 84 | mapId :: (a -> b) -> Id a -> Id b 85 | mapId = (…) 86 | 87 | -- Just for comparison, here are the implementations that you might write by 88 | -- hand 89 | 90 | id' x = x 91 | const' x _= x 92 | flip' f a b = f b a 93 | dup' x = (x,x) 94 | pair' x y = (x,y) 95 | tripl' x y z = (x,y,z) 96 | proj' (_,_,c,_) = c 97 | curry' f a b = f (a,b) 98 | curryFlip' f a b = f (b,a) 99 | unit' = Unit 100 | mapId' f (Id x) = Id (f x) 101 | contBind' :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r) 102 | contBind' ca cb k = ca (\a -> cb a k) 103 | swapEither' (Left a) = (Right a) 104 | swapEither' (Right a) = (Left a) 105 | swapEitherCont' :: (((Either a b) -> r) -> r) -> (((Either b a) -> r) -> r) 106 | swapEitherCont' ca k = ca $ \case Left a -> k (Right a) 107 | Right a -> k (Left a) 108 | absurd' :: Void -> a 109 | absurd' = \case{} 110 | errReadBind' m1 m2 r = case m1 r of Left e -> Left e 111 | Right a -> m2 a r 112 | errReadBindTup' m1 m2 r = case m1 r of 113 | Left e -> Left e 114 | Right a -> case m2 a r of Left e -> Left e 115 | Right b -> Right (a,b) 116 | 117 | errReadBindTup2' :: ErrRead r e a -> (a -> ErrRead r e b) -> ErrRead r e (a,b) 118 | errReadBindTup2' m1 m2 = ErrRead $ \r -> case unErrRead m1 r of 119 | Failure e -> Failure e 120 | Success a -> case unErrRead (m2 a) r of Failure e -> Failure e 121 | Success b -> Success (a,b) 122 | 123 | -- Here are functions where we do not infer the expected code, due to the order 124 | -- things are looked at. 125 | errReadAp' m1 m2 r = case m2 r of Left e -> case m1 r of Left e -> Left e 126 | Right _ -> Left e 127 | Right x -> case m1 r of Left e -> Left e 128 | Right f -> Right (f x) 129 | contAp' :: (((a -> b) -> r) -> r) -> ((a -> r) -> r) -> ((b -> r) -> r) 130 | contAp' ca cb k = cb (\x -> ca (\f -> k (f x))) 131 | 132 | -- And here we use inspection-testing to check that these are indeed the 133 | -- definitions that GHC.JustDoIt created for us. 134 | 135 | inspect $ 'id === 'id' 136 | inspect $ 'const === 'const' 137 | inspect $ 'flip === 'flip' 138 | inspect $ 'dup === 'dup' 139 | inspect $ 'pair === 'pair' 140 | inspect $ 'tripl === 'tripl' 141 | inspect $ 'proj === 'proj' 142 | inspect $ 'curry === 'curry' 143 | inspect $ 'curryFlip === 'curryFlip' 144 | inspect $ 'unit === 'unit' 145 | inspect $ 'contBind === 'contBind' 146 | inspect $ 'contAp === 'contAp' 147 | inspect $ 'swapEither === 'swapEither' 148 | inspect $ 'swapEitherCont === 'swapEitherCont' 149 | inspect $ 'absurd === 'absurd' 150 | inspect $ 'mapId === 'mapId' 151 | inspect $ 'errReadBind === 'errReadBind' 152 | inspect $ 'errReadBindTup === 'errReadBindTup' 153 | inspect $ 'errReadBindTup2 ==- 'errReadBindTup2' -- type variable order differences 154 | inspect $ 'errReadAp === 'errReadAp' 155 | 156 | main :: IO () 157 | main = putStrLn "☺" 158 | -------------------------------------------------------------------------------- /ghc-justdoit.cabal: -------------------------------------------------------------------------------- 1 | name: ghc-justdoit 2 | version: 0.1.0.2 3 | synopsis: A magic typeclass that just does it 4 | description: 5 | This plugin allows you to write 6 | . 7 | @ 8 | {-\# OPTIONS_GHC -fplugin GHC.JustDoIt.Plugin \#-} 9 | module Test where 10 | . 11 | import GHC.JustDoIt 12 | . 13 | foo :: ((a -> r) -> r) -> (a -> ((b -> r) -> r)) -> ((b -> r) -> r) 14 | foo = (…) 15 | @ 16 | . 17 | without having to write the actual implementation of `foo`. 18 | . 19 | See 20 | for a few examples of what this plugin can do for you. 21 | 22 | homepage: https://github.com/nomeata/ghc-justdoit 23 | license: MIT 24 | license-file: LICENSE 25 | author: Joachim Breitner 26 | maintainer: mail@joachim-breitner.de 27 | copyright: 2018 Joachim Breitner 28 | category: Language 29 | build-type: Simple 30 | extra-source-files: ChangeLog.md, README.md 31 | cabal-version: >=1.10 32 | tested-with: GHC ==9.0.* 33 | 34 | library 35 | exposed-modules: GHC.LJT 36 | exposed-modules: GHC.JustDoIt 37 | exposed-modules: GHC.JustDoIt.Plugin 38 | exposed-modules: GHC.JustDoIt.Solver 39 | build-depends: base >=4.15 && <4.16 40 | build-depends: hashable 41 | build-depends: ghc >=9.0 42 | default-language: Haskell2010 43 | 44 | test-suite demo 45 | type: exitcode-stdio-1.0 46 | main-is: Demo.hs 47 | hs-source-dirs: examples/ 48 | build-depends: base 49 | build-depends: ghc-justdoit 50 | build-depends: inspection-testing 51 | default-language: Haskell2010 52 | 53 | source-repository head 54 | type: git 55 | location: git://github.com/nomeata/ghc-justdoit.git 56 | --------------------------------------------------------------------------------