├── .gitignore
├── README.md
├── default.nix
├── djinn-hoogle-mod-plugin
    ├── DjinnBridge.hs
    ├── DjinnHoogleModPlugin.cabal
    ├── DjinnHoogleModPlugin.hs
    ├── README.md
    ├── Test
    │   ├── Main.hs
    │   └── Test.cabal
    └── cabal.project
├── djinn-plugin
    ├── .ghci
    ├── DjinnBridge.hs
    ├── DjinnPlugin.cabal
    ├── DjinnPlugin.hs
    ├── README.md
    ├── Test
    │   ├── Main.hs
    │   └── Test.cabal
    └── cabal.project
├── hoogle-plugin
    ├── HolePlugin.cabal
    ├── HolePlugin.hs
    ├── README.md
    ├── Test
    │   ├── Main.hs
    │   └── test.cabal
    └── cabal.project
├── hplus-plugin
    ├── HPlusPlugin.cabal
    ├── HPlusPlugin.hs
    ├── README.md
    ├── Test
    │   ├── Main.hs
    │   └── Test.cabal
    ├── default.nix
    └── lookup
├── non-empty-holes-plugin
    ├── DjinnBridge.hs
    ├── NonEmptyHolesPlugin.cabal
    ├── NonEmptyHolesPlugin.hs
    ├── README.md
    ├── Test
    │   ├── Main.hs
    │   ├── Test.cabal
    │   ├── out
    │   └── stdin
    └── cabal.project
└── quickcheck-plugin
    ├── HolePlugin.cabal
    ├── HolePlugin.hs
    ├── README.md
    ├── Test
        ├── FindFit.hs
        ├── Main.hs
        ├── MainOrig.hs
        ├── ProgInput.hs
        ├── genFits.sh
        ├── genHoles.sh
        └── test.cabal
    └── cabal.project


/.gitignore:
--------------------------------------------------------------------------------
 1 | dist-newstyle/
 2 | **/dist-newstyle/
 3 | dist/
 4 | **/dist/
 5 | .ghc.environment.*
 6 | 
 7 | **/out.fits
 8 | **/head.hackage
 9 | **/FitTest.hs
10 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | ExampleHolePlugin
 2 | =================
 3 | 
 4 | This repository contains a collection of example hole fit plugins for GHC.
 5 | 
 6 | Note! Needs GHC 8.10 for regular holes, and a custom branch for extended holes.
 7 | 
 8 | Checkout the plugins in the directories:
 9 | 
10 | + The [Hoogle Plugin](hoogle-plugin/) shows an example of how you can filter by candidates by module, but also how you can interact with command line tools such as Hoogle.
11 | + The [Djinn Plugin](djinn-plugin/) show an example how state can be used to communicate between the candidate and fit plugin and between invocations, by using `djinn` to synthesize hole fits. Based on `djinn-ghc` by Alejandro Serrano.
12 | + The [QuickCheck Plugin](quickcheck-plugin/) shows how hole fit plugins can be used to automatically pick the right hole fit based on QuickCheck properties.
13 | + The [Extended Holes Plugin](extended-holes-plugin/) shows how extended holes can be used to communicate with plugins.
14 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | let
 2 |   unstable = import <unstable> { };
 3 | in
 4 | { nixpkgs ? import <nixpkgs> { } }:
 5 | with nixpkgs;
 6 | let
 7 |   hspkgs = unstable.haskell.packages.ghc8101;
 8 |   pkgs = [
 9 |     hspkgs.ghc
10 |   ];
11 | 
12 | in nixpkgs.stdenv.mkDerivation {
13 |   name = "env";
14 |   buildInputs = pkgs;
15 | }
16 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/DjinnBridge.hs:
--------------------------------------------------------------------------------
  1 | --- Based on djinn-ghc by Alejandro Serrano, but reworked to use TcM directly.
  2 | 
  3 | {-# LANGUAGE CPP, PatternGuards, BangPatterns #-}
  4 | module DjinnBridge (Environment, MaxSolutions(..), djinn) where
  5 | 
  6 | import Control.Concurrent
  7 | import Control.Concurrent.Async
  8 | import Control.Monad (forM)
  9 | import Data.Set (Set, insert, union, unions, empty, toList)
 10 | 
 11 | import qualified Djinn.HTypes as D
 12 | import qualified Djinn.LJT as D
 13 | 
 14 | import qualified TcEnv as TE
 15 | import TcRnTypes
 16 | import qualified GhcPlugins as GP
 17 | 
 18 | import MonadUtils
 19 | import qualified DataCon as G
 20 | import qualified GHC as G
 21 | import qualified Name as G
 22 | import qualified TyCon as G
 23 | import qualified Type as G
 24 | 
 25 | import Data.Maybe (mapMaybe, catMaybes, isJust)
 26 | 
 27 | 
 28 | data NoExtraInfo = NoExtraInfo
 29 | type HEnvironment1 a = [(D.HSymbol, ([D.HSymbol], D.HType, a))]
 30 | type HEnvironment = HEnvironment1 NoExtraInfo
 31 | 
 32 | getConTs :: G.Type -> Set G.Name
 33 | getConTs t | Just (_, i)  <- G.splitForAllTy_maybe t = getConTs i
 34 | getConTs t | Just (t1,t2) <- G.splitFunTy_maybe t    = getConTs t1 `union` getConTs t2
 35 | getConTs t | Just t1 <- G.splitListTyConApp_maybe t = getConTs t1
 36 | getConTs t | Just (c, ts) <- G.splitTyConApp_maybe t =
 37 |   let args = unions $ map getConTs ts
 38 |   in if G.isTupleTyCon c then args else insert (G.getName c) args
 39 | getConTs t | Just (t1,t2) <- G.splitAppTy_maybe t    = getConTs t1 `union` getConTs t2
 40 | getConTs t | Just _       <- G.getTyVar_maybe t      = empty
 41 | getConTs _                                           = empty
 42 | 
 43 | mbHType :: G.Type -> Maybe D.HType
 44 | mbHType t | Just (_, i)  <- G.splitForAllTy_maybe t = mbHType  i
 45 | mbHType t | Just (t1,t2) <- G.splitFunTy_maybe t    = do ht1 <- mbHType t1
 46 |                                                          ht2 <- mbHType t2
 47 |                                                          return $ D.HTArrow ht1 ht2
 48 | mbHType t | Just (c, ts) <- G.splitTyConApp_maybe t = do
 49 |               args <- mapM mbHType ts
 50 |               if G.isTupleTyCon c  -- Check if we have a tuple
 51 |                 then if not (null args)
 52 |                      then Just $ D.HTTuple args
 53 |                      -- The unit constructor () is also a tupeTyCon, but this case
 54 |                      -- causes the show instance in Djinn to fail, so we drop it.
 55 |                      else Nothing
 56 |                 else Just $ createHTApp (G.getOccString c) (reverse args)
 57 |   where createHTApp n []     = D.HTCon n
 58 |         createHTApp n (x:xs) = D.HTApp (createHTApp n xs) x
 59 | mbHType t | Just (t1,t2) <- G.splitAppTy_maybe t  = do ht1 <- mbHType t1
 60 |                                                        ht2 <- mbHType t2
 61 |                                                        return $ D.HTApp ht1 ht2
 62 | mbHType t | Just var <- G.getTyVar_maybe t          = Just $ D.HTVar (toHSymbol var)
 63 | mbHType _                                           = Nothing
 64 | 
 65 | environment :: G.Type -> TcM HEnvironment
 66 | environment ty = do
 67 |   let tyConTs = getConTs ty
 68 |   concat <$> mapM environment1 (toList tyConTs)
 69 | 
 70 | environment1 :: G.Name -> TcM HEnvironment
 71 | environment1 name = do
 72 |   thing <- TE.tcLookupGlobal name
 73 |   case thing of
 74 |     G.ATyCon tycon | G.isAlgTyCon tycon -> do
 75 |       let tyconName = toHSymbol $ G.tyConName tycon
 76 |           varsH = map toHSymbol $ G.tyConTyVars tycon
 77 |           Just datacons = G.tyConDataCons_maybe tycon
 78 |       dtypes <- forM datacons $ \dcon -> do
 79 |         let dconN = toHSymbol $ G.dataConName dcon
 80 |             (_,_,dconT,_) = G.dataConSig dcon
 81 |         dconE <- mapM environment dconT
 82 |         return $ do dconTTys <- mapM mbHType dconT
 83 |                     return ((dconN, dconTTys), dconE)
 84 |       return $ if all isJust dtypes
 85 |                then let dtypesT = map fst $ catMaybes dtypes
 86 |                         dtypesE = concatMap snd $ catMaybes dtypes
 87 |                     in (tyconName, (varsH, D.HTUnion dtypesT, NoExtraInfo)) : concat dtypesE
 88 |                else []
 89 |     G.ATyCon tycon | G.isTypeSynonymTyCon tycon -> do
 90 |       -- Get information for this type synonym
 91 |       let tyconName = toHSymbol $ G.tyConName tycon
 92 |           Just (vars, defn) = G.synTyConDefn_maybe tycon
 93 |           varsH = map toHSymbol vars
 94 |       -- Recursively obtain it for the environment of the type
 95 |       case mbHType defn of
 96 |         Just htype -> do defnEnv <- environment defn
 97 |                          return $ (tyconName, (varsH, htype, NoExtraInfo)) : defnEnv
 98 |         _ -> return []
 99 |     _ -> return []
100 |     --         return []
101 | 
102 | toHSymbol :: G.NamedThing a => a -> D.HSymbol
103 | toHSymbol = G.getOccString
104 | 
105 | toLJTSymbol :: G.NamedThing a => a -> D.Symbol
106 | toLJTSymbol = D.Symbol . G.getOccString
107 | 
108 | -- |Bindings which are in scope at a specific point.
109 | type Environment = [(G.Name, G.Type)]
110 | 
111 | -- |Obtain a maximum number of solutions.
112 | newtype MaxSolutions = Max Int
113 | 
114 | 
115 | -- |Obtain the list of expressions which could fill
116 | -- something with the given type.
117 | -- The first flag specifies whether to return one
118 | -- or more solutions to the problem.
119 | djinn :: Bool -> Environment -> G.Type -> MaxSolutions -> Int -> TcM [String]
120 | djinn multi env ty (Max mx) microsec = do
121 |   tyEnv <- environment ty
122 |   case mbHType ty of
123 |     Just hT -> let form = D.hTypeToFormula tyEnv hT
124 |                    toEnvF (n, t) =
125 |                       case mbHType t of
126 |                         Just ht -> Just (toLJTSymbol n, D.hTypeToFormula tyEnv ht)
127 |                         _ -> Nothing
128 |                    envF = mapMaybe toEnvF env
129 |                    prfs = D.prove multi envF form
130 |                    trms =  map (D.hPrExpr . D.termToHExpr ) prfs
131 |                in liftIO $ cropList trms microsec mx (\x -> GP.lengthLessThan x 1000)
132 |     _ -> return []
133 | 
134 | cropList :: [a] -> Int -> Int -> (a -> Bool) -> IO [a]
135 | cropList _   _  0 _ = return []
136 | cropList lst ms n chk =
137 |   withAsync (let !l = lst in return l) $ \a -> do
138 |     threadDelay ms
139 |     res <- poll a
140 |     case res of
141 |       Just r -> case r of
142 |         Right (x:xs) -> if chk x then do ys <- cropList xs ms (n-1) chk
143 |                                          return $ x : ys
144 |                                  else return []
145 |         _            -> return []
146 |       Nothing -> do cancel a
147 |                     return []
148 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/DjinnHoogleModPlugin.cabal:
--------------------------------------------------------------------------------
 1 | name: DjinnHoogleModPlugin
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | 
 7 | library
 8 |   default-language: Haskell2010
 9 |   build-depends: base, ghc, time, djinn-lib, containers, async, process
10 |   exposed-modules: DjinnHoogleModPlugin, DjinnBridge
11 |   ghc-options: -Wall
12 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/DjinnHoogleModPlugin.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE TypeApplications, RecordWildCards #-}
  2 | module DjinnHoogleModPlugin where
  3 | 
  4 | import GhcPlugins hiding ((<>))
  5 | 
  6 | import TcHoleErrors
  7 | 
  8 | import Constraint
  9 | 
 10 | import TcRnMonad
 11 | 
 12 | import DjinnBridge
 13 | 
 14 | import ConLike(conLikeWrapId_maybe)
 15 | import TcEnv (tcLookup)
 16 | import Data.Maybe (catMaybes)
 17 | 
 18 | import Data.List (sortOn)
 19 | 
 20 | import qualified Data.Set as Set
 21 | 
 22 | import Data.List (intersect, stripPrefix)
 23 | -- import RdrName (importSpecModule)
 24 | 
 25 | import System.Process
 26 | 
 27 | 
 28 | data HolePluginState = HPS { djinnEnv :: Environment
 29 |                            , maxSols :: MaxSolutions
 30 |                            , microSecs :: Int}
 31 | 
 32 | setDjinnEnv :: Environment -> HolePluginState -> HolePluginState
 33 | setDjinnEnv e (HPS _ sols secs)  = HPS e sols secs
 34 | 
 35 | initPlugin :: [CommandLineOption] -> TcM (TcRef HolePluginState)
 36 | -- We take more than we need since djinn is prone to duplicate solutions...
 37 | initPlugin _ = newTcRef $ HPS [] (Max 20) (40000 :: Int)
 38 | 
 39 | 
 40 | -- | Adds the current candidates to scope in djinn.
 41 | djinnAddToScopeP :: TcRef HolePluginState -> CandPlugin
 42 | djinnAddToScopeP ref _ cands = do
 43 |   newEnv <- catMaybes <$> mapM hfLookup cands
 44 |   --liftIO $ print $ map (showSDocUnsafe . ppr) newEnv
 45 |   updTcRef ref (setDjinnEnv newEnv)
 46 |   return cands
 47 |   where hfLookup :: HoleFitCandidate -> TcM (Maybe (Name,Type))
 48 |         hfLookup hfc = tryTcDiscardingErrs (return Nothing) $ do
 49 |           let name = getName hfc
 50 |           thing <- tcLookup name
 51 |           let thingId = case thing of
 52 |                           ATcId {tct_id = i} ->  Just i
 53 |                           AGlobal (AnId i)   ->  Just i
 54 |                           AGlobal (AConLike con) -> conLikeWrapId_maybe con
 55 |                           _ -> Nothing
 56 |           case thingId of
 57 |             Just i -> return $ Just (name, idType i)
 58 |             _ -> return Nothing
 59 | 
 60 | 
 61 | djinnSynthP :: TcRef HolePluginState -> FitPlugin
 62 | djinnSynthP ref TyH{tyHImplics = imps, tyHCt = Just holeCt} fits = do
 63 |   HPS {..} <- readTcRef ref
 64 |   let wrappedType = foldl wrapTypeWithImplication (ctPred holeCt) imps
 65 |   --liftIO $ print $ map (showSDocUnsafe . ppr) djinnEnv
 66 |   -- liftIO $ print (showSDocUnsafe . ppr $ wrappedType)
 67 |   let splitSols = unwords . words . unwords . lines
 68 |       solToHf = RawHoleFit . parens . text
 69 |       Max numToShow = maxSols
 70 |   sols <- map splitSols <$> djinn True djinnEnv wrappedType maxSols microSecs
 71 |           -- We could set '-fdefer-typed-holes'  and load the module here...
 72 |           -- modInfo <- moduleInfo <$>
 73 |   let djinnSols = map solToHf $
 74 |                     take (numToShow `div` 10) $
 75 |                       sortOn length $ dedup sols
 76 |   return $ djinnSols <> fits
 77 | djinnSynthP _ _ _ = return []
 78 | 
 79 | -- Lazily de-duplicate a list
 80 | dedup :: Ord a => [a] -> [a]
 81 | dedup = dedup' Set.empty
 82 |   where dedup' sofar (x:xs) | x `Set.member` sofar = dedup' sofar xs
 83 |         dedup' sofar (x:xs) = x:dedup' (x `Set.insert` sofar) xs
 84 |         dedup' _ [] = []
 85 | 
 86 | 
 87 | data PluginType = Djinn 
 88 |                 | Hoogle
 89 |                 | Mod String
 90 |                 | None
 91 |                 deriving (Eq)
 92 | 
 93 | toPluginType :: Maybe String -> PluginType
 94 | toPluginType (Just holeName) =
 95 |     case holeName of 
 96 |         "_invoke_Djinn" -> Djinn
 97 |         "_invoke_Hoogle" -> Hoogle
 98 |         _ -> case stripPrefix "_module_" holeName of
 99 |                 Just undScModName -> Mod $ replace '_' '.' undScModName
100 |                 _ -> None
101 |     where replace :: Eq a => a -> a -> [a] -> [a]
102 |           replace match repl str = replace' [] str
103 |             where replace' sofar (x:xs) | x == match = replace' (repl:sofar) xs
104 |                   replace' sofar (x:xs) = replace' (x:sofar) xs
105 |                   replace' sofar [] = reverse sofar
106 | toPluginType _ = None
107 | 
108 | 
109 | djinnHoogleModCP :: TcRef HolePluginState -> CandPlugin
110 | djinnHoogleModCP ref hole cands =
111 |   do let holeN = case tyHCt hole of
112 |                 Just (CHoleCan _ h ExprHole) -> Just (occNameString h)
113 |                 _ -> Nothing
114 |      case toPluginType holeN of
115 |         -- Pass to the Djinn plugin
116 |         Djinn -> djinnAddToScopeP ref hole cands
117 |         -- Filter by where the elemnet comes from 
118 |         Mod modName -> return $ filter (greNotInOpts [modName]) cands
119 |         _ -> return cands
120 |   where greNotInOpts opts (GreHFCand gre) = not $ null $ intersect (inScopeVia gre) opts
121 |         greNotInOpts _ _ = True
122 |         inScopeVia = map (moduleNameString . importSpecModule) . gre_imp
123 | 
124 | 
125 | plugin :: Plugin
126 | plugin = defaultPlugin { holeFitPlugin = holeFitP, pluginRecompile = purePlugin}
127 | 
128 | holeFitP :: [CommandLineOption] -> Maybe HoleFitPluginR
129 | holeFitP opts = Just (HoleFitPluginR initP pluginDef stopP)
130 |   where initP = initPlugin opts
131 |         stopP = const $ return ()
132 |         pluginDef ref = HoleFitPlugin { candPlugin = djinnHoogleModCP ref
133 |                                       , fitPlugin  = djinnHoogleModFP ref }
134 | 
135 | 
136 | djinnHoogleModFP :: TcRef HolePluginState -> FitPlugin
137 | djinnHoogleModFP ref hole hfs =
138 |   do let holeN = case tyHCt hole of
139 |                 Just (CHoleCan _ h ExprHole) -> Just (occNameString h)
140 |                 _ -> Nothing
141 |      case toPluginType holeN of
142 |         Djinn -> djinnSynthP ref hole hfs
143 |         Hoogle -> hoogleFP hole hfs
144 |         _ -> return hfs
145 | 
146 | 
147 | searchHoogle :: String -> IO [String]
148 | searchHoogle ty = lines <$> (readProcess "hoogle" [(show ty)] [])
149 | 
150 | hoogleFP :: FitPlugin
151 | hoogleFP hole hfs =
152 |     do dflags <- getDynFlags
153 |        let tyString = showSDoc dflags . ppr . ctPred <$> tyHCt hole
154 |        res <- case tyString of
155 |                 Just ty -> liftIO $ searchHoogle ty
156 |                 _ -> return []
157 |        return $ (take 2 $ map (RawHoleFit . text . ("Hoogle: " ++)) res) ++ hfs
158 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/README.md:
--------------------------------------------------------------------------------
  1 | The Djinn Hoogle Module Plugin
  2 | =================
  3 | 
  4 | The Djinn Hoogle Module Plugin showcases some basic hole fit plugin functionality,
  5 | including how to combine multiple plugins into one by using the name of holes.
  6 | 
  7 | This plugin shows how `djinn` can be invoked by a hole fit plugin to synthesize simple programs, how
  8 | `hoogle` can be invoked by the compiler to search for a fit by the type, and how candidates can be
  9 | filtered by module.
 10 | 
 11 | `DjinnBridge` is based on the `djinn-ghc` package by Alejandro Serrano but modified to use `TcM` directly.
 12 | 
 13 | Note! Needs GHC 8.10
 14 | 
 15 | Example Output
 16 | -----------------
 17 | 
 18 | Using this plugin, you can compile the following (using `cabal new-build test` with a freshly built GHC HEAD):
 19 | 
 20 | ```haskell
 21 | {-# OPTIONS -fplugin=DjinnHoogleModPlugin
 22 |             -funclutter-valid-hole-fits #-}
 23 | module Main where
 24 | import Control.Monad
 25 | f :: (a,b) -> a
 26 | f = _invoke_Djinn
 27 | g :: [a] -> [[a]]
 28 | g = _invoke_Hoogle
 29 | h :: [[a]] -> [a]
 30 | h = _module_Control_Monad
 31 | 
 32 | 
 33 | main :: IO ()
 34 | main = return ()
 35 | ```
 36 | 
 37 | 
 38 | And get the following output:
 39 | 
 40 | ```
 41 | 
 42 | Main.hs:6:5: error:
 43 |     • Found hole: _invoke_Djinn :: (a, b) -> a
 44 |       Where: ‘b’, ‘a’ are rigid type variables bound by
 45 |                the type signature for:
 46 |                  f :: forall a b. (a, b) -> a
 47 |                at Main.hs:5:1-15
 48 |       Or perhaps ‘_invoke_Djinn’ is mis-spelled, or not in scope
 49 |     • In the expression: _invoke_Djinn
 50 |       In an equation for ‘f’: f = _invoke_Djinn
 51 |     • Relevant bindings include f :: (a, b) -> a (bound at Main.hs:6:1)
 52 |       Valid hole fits include
 53 |         (\ (a, _) -> a)
 54 |         (\ _ -> head (cycle (h (g ([])) ++ h (g ([])))))
 55 |         f :: (a, b) -> a
 56 |         fst :: forall a b. (a, b) -> a
 57 |   |
 58 | 6 | f = _invoke_Djinn
 59 |   |     ^^^^^^^^^^^^^
 60 | 
 61 | Main.hs:8:5: error:
 62 |     • Found hole: _invoke_Hoogle :: [a] -> [[a]]
 63 |       Where: ‘a’ is a rigid type variable bound by
 64 |                the type signature for:
 65 |                  g :: forall a. [a] -> [[a]]
 66 |                at Main.hs:7:1-17
 67 |       Or perhaps ‘_invoke_Hoogle’ is mis-spelled, or not in scope
 68 |     • In the expression: _invoke_Hoogle
 69 |       In an equation for ‘g’: g = _invoke_Hoogle
 70 |     • Relevant bindings include
 71 |         g :: [a] -> [[a]] (bound at Main.hs:8:1)
 72 |       Valid hole fits include
 73 |         Hoogle says: Data.List subsequences :: [a] -> [[a]]
 74 |         Hoogle says: Data.List permutations :: [a] -> [[a]]
 75 |         g :: [a] -> [[a]]
 76 |         repeat :: forall a. a -> [a]
 77 |         return :: forall (m :: * -> *) a. Monad m => a -> m a
 78 |         pure :: forall (f :: * -> *) a. Applicative f => a -> f a
 79 |         (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
 80 |   |
 81 | 8 | g = _invoke_Hoogle
 82 |   |     ^^^^^^^^^^^^^^
 83 | 
 84 | Main.hs:10:5: error:
 85 |     • Found hole: _module_Control_Monad :: [[a]] -> [a]
 86 |       Where: ‘a’ is a rigid type variable bound by
 87 |                the type signature for:
 88 |                  h :: forall a. [[a]] -> [a]
 89 |                at Main.hs:9:1-17
 90 |       Or perhaps ‘_module_Control_Monad’ is mis-spelled, or not in scope
 91 |     • In the expression: _module_Control_Monad
 92 |       In an equation for ‘h’: h = _module_Control_Monad
 93 |     • Relevant bindings include
 94 |         h :: [[a]] -> [a] (bound at Main.hs:10:1)
 95 |       Valid hole fits include
 96 |         h :: [[a]] -> [a]
 97 |         join :: forall (m :: * -> *) a. Monad m => m (m a) -> m a
 98 |         msum :: forall (t :: * -> *) (m :: * -> *) a.
 99 |                 (Foldable t, MonadPlus m) =>
100 |                 t (m a) -> m a
101 |         forever :: forall (f :: * -> *) a b. Applicative f => f a -> f b
102 |    |
103 | 10 | h = _module_Control_Monad
104 |    |     ^^^^^^^^^^^^^^^^^^^^^
105 | ```
106 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/Test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=DjinnHoogleModPlugin
 2 |             -funclutter-valid-hole-fits #-}
 3 | module Main where
 4 | import Control.Monad
 5 | f :: (a,b,c) -> a
 6 | f = _invoke_Djinn
 7 | f2 :: (a,b,c) -> a
 8 | f2 = _invoke_Hoogle
 9 | g :: [a] -> [[a]]
10 | g = _invoke_Hoogle
11 | h :: [[a]] -> [a]
12 | h = _module_Control_Monad
13 | 
14 | 
15 | main :: IO ()
16 | main = return ()
17 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/Test/Test.cabal:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | executable test
 7 |   default-language: Haskell2010
 8 |   build-depends: base, DjinnHoogleModPlugin
 9 |   main-is: Main.hs
10 |   ghc-options: -Wall
11 | 


--------------------------------------------------------------------------------
/djinn-hoogle-mod-plugin/cabal.project:
--------------------------------------------------------------------------------
1 | packages: ./
2 |           ./Test
3 | 
4 | allow-newer: all
5 | 


--------------------------------------------------------------------------------
/djinn-plugin/.ghci:
--------------------------------------------------------------------------------
1 | :set -fplugin-opt=DjinnPlugin:1
2 | :set -fplugin=DjinnPlugin 
3 | 


--------------------------------------------------------------------------------
/djinn-plugin/DjinnBridge.hs:
--------------------------------------------------------------------------------
  1 | --- Based on djinn-ghc by Alejandro Serrano, but reworked to use TcM directly.
  2 | 
  3 | {-# LANGUAGE CPP, PatternGuards, BangPatterns #-}
  4 | module DjinnBridge (Environment, MaxSolutions(..), djinn) where
  5 | 
  6 | import Control.Concurrent
  7 | import Control.Concurrent.Async
  8 | import Control.Monad (forM)
  9 | import Data.Set (Set, insert, union, unions, empty, toList)
 10 | 
 11 | import qualified Djinn.HTypes as D
 12 | import qualified Djinn.LJT as D
 13 | 
 14 | import qualified TcEnv as TE
 15 | import TcRnTypes
 16 | import qualified GhcPlugins as GP
 17 | 
 18 | import MonadUtils
 19 | import qualified DataCon as G
 20 | import qualified GHC as G
 21 | import qualified Name as G
 22 | import qualified TyCon as G
 23 | import qualified Type as G
 24 | 
 25 | import Data.Maybe (mapMaybe, catMaybes, isJust)
 26 | 
 27 | 
 28 | data NoExtraInfo = NoExtraInfo
 29 | type HEnvironment1 a = [(D.HSymbol, ([D.HSymbol], D.HType, a))]
 30 | type HEnvironment = HEnvironment1 NoExtraInfo
 31 | 
 32 | getConTs :: G.Type -> Set G.Name
 33 | getConTs t | Just (_, i)  <- G.splitForAllTy_maybe t = getConTs i
 34 | getConTs t | Just (t1,t2) <- G.splitFunTy_maybe t    = getConTs t1 `union` getConTs t2
 35 | getConTs t | Just t1 <- G.splitListTyConApp_maybe t = getConTs t1
 36 | getConTs t | Just (c, ts) <- G.splitTyConApp_maybe t =
 37 |   let args = unions $ map getConTs ts
 38 |   in if G.isTupleTyCon c then args else insert (G.getName c) args
 39 | getConTs t | Just (t1,t2) <- G.splitAppTy_maybe t    = getConTs t1 `union` getConTs t2
 40 | getConTs t | Just _       <- G.getTyVar_maybe t      = empty
 41 | getConTs _                                           = empty
 42 | 
 43 | mbHType :: G.Type -> Maybe D.HType
 44 | mbHType t | Just (_, i)  <- G.splitForAllTy_maybe t = mbHType  i
 45 | mbHType t | Just (t1,t2) <- G.splitFunTy_maybe t    = do ht1 <- mbHType t1
 46 |                                                          ht2 <- mbHType t2
 47 |                                                          return $ D.HTArrow ht1 ht2
 48 | mbHType t | Just (c, ts) <- G.splitTyConApp_maybe t = do
 49 |               args <- mapM mbHType ts
 50 |               if G.isTupleTyCon c  -- Check if we have a tuple
 51 |                 then if not (null args)
 52 |                      then Just $ D.HTTuple args
 53 |                      -- The unit constructor () is also a tupeTyCon, but this case
 54 |                      -- causes the show instance in Djinn to fail, so we drop it.
 55 |                      else Nothing
 56 |                 else Just $ createHTApp (G.getOccString c) (reverse args)
 57 |   where createHTApp n []     = D.HTCon n
 58 |         createHTApp n (x:xs) = D.HTApp (createHTApp n xs) x
 59 | mbHType t | Just (t1,t2) <- G.splitAppTy_maybe t  = do ht1 <- mbHType t1
 60 |                                                        ht2 <- mbHType t2
 61 |                                                        return $ D.HTApp ht1 ht2
 62 | mbHType t | Just var <- G.getTyVar_maybe t          = Just $ D.HTVar (toHSymbol var)
 63 | mbHType _                                           = Nothing
 64 | 
 65 | environment :: G.Type -> TcM HEnvironment
 66 | environment ty = do
 67 |   let tyConTs = getConTs ty
 68 |   concat <$> mapM environment1 (toList tyConTs)
 69 | 
 70 | environment1 :: G.Name -> TcM HEnvironment
 71 | environment1 name = do
 72 |   thing <- TE.tcLookupGlobal name
 73 |   case thing of
 74 |     G.ATyCon tycon | G.isAlgTyCon tycon -> do
 75 |       let tyconName = toHSymbol $ G.tyConName tycon
 76 |           varsH = map toHSymbol $ G.tyConTyVars tycon
 77 |           Just datacons = G.tyConDataCons_maybe tycon
 78 |       dtypes <- forM datacons $ \dcon -> do
 79 |         let dconN = toHSymbol $ G.dataConName dcon
 80 |             (_,_,dconT,_) = G.dataConSig dcon
 81 |         dconE <- mapM environment dconT
 82 |         return $ do dconTTys <- mapM mbHType dconT
 83 |                     return ((dconN, dconTTys), dconE)
 84 |       return $ if all isJust dtypes
 85 |                then let dtypesT = map fst $ catMaybes dtypes
 86 |                         dtypesE = concatMap snd $ catMaybes dtypes
 87 |                     in (tyconName, (varsH, D.HTUnion dtypesT, NoExtraInfo)) : concat dtypesE
 88 |                else []
 89 |     G.ATyCon tycon | G.isTypeSynonymTyCon tycon -> do
 90 |       -- Get information for this type synonym
 91 |       let tyconName = toHSymbol $ G.tyConName tycon
 92 |           Just (vars, defn) = G.synTyConDefn_maybe tycon
 93 |           varsH = map toHSymbol vars
 94 |       -- Recursively obtain it for the environment of the type
 95 |       case mbHType defn of
 96 |         Just htype -> do defnEnv <- environment defn
 97 |                          return $ (tyconName, (varsH, htype, NoExtraInfo)) : defnEnv
 98 |         _ -> return []
 99 |     _ -> return []
100 |     --         return []
101 | 
102 | toHSymbol :: G.NamedThing a => a -> D.HSymbol
103 | toHSymbol = G.getOccString
104 | 
105 | toLJTSymbol :: G.NamedThing a => a -> D.Symbol
106 | toLJTSymbol = D.Symbol . G.getOccString
107 | 
108 | -- |Bindings which are in scope at a specific point.
109 | type Environment = [(G.Name, G.Type)]
110 | 
111 | -- |Obtain a maximum number of solutions.
112 | newtype MaxSolutions = Max Int
113 | 
114 | 
115 | -- |Obtain the list of expressions which could fill
116 | -- something with the given type.
117 | -- The first flag specifies whether to return one
118 | -- or more solutions to the problem.
119 | djinn :: Bool -> Environment -> G.Type -> MaxSolutions -> Int -> TcM [String]
120 | djinn multi env ty (Max mx) microsec = do
121 |   tyEnv <- environment ty
122 |   case mbHType ty of
123 |     Just hT -> let form = D.hTypeToFormula tyEnv hT
124 |                    toEnvF (n, t) =
125 |                       case mbHType t of
126 |                         Just ht -> Just (toLJTSymbol n, D.hTypeToFormula tyEnv ht)
127 |                         _ -> Nothing
128 |                    envF = mapMaybe toEnvF env
129 |                    prfs = D.prove multi envF form
130 |                    trms =  map (D.hPrExpr . D.termToHExpr ) prfs
131 |                in liftIO $ cropList trms microsec mx (\x -> GP.lengthLessThan x 1000)
132 |     _ -> return []
133 | 
134 | cropList :: [a] -> Int -> Int -> (a -> Bool) -> IO [a]
135 | cropList _   _  0 _ = return []
136 | cropList lst ms n chk =
137 |   withAsync (let !l = lst in return l) $ \a -> do
138 |     threadDelay ms
139 |     res <- poll a
140 |     case res of
141 |       Just r -> case r of
142 |         Right (x:xs) -> if chk x then do ys <- cropList xs ms (n-1) chk
143 |                                          return $ x : ys
144 |                                  else return []
145 |         _            -> return []
146 |       Nothing -> do cancel a
147 |                     return []
148 | 


--------------------------------------------------------------------------------
/djinn-plugin/DjinnPlugin.cabal:
--------------------------------------------------------------------------------
 1 | name: DjinnPlugin
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | 
 7 | library
 8 |   default-language: Haskell2010
 9 |   build-depends: base, ghc, time, djinn-lib, containers, async
10 |   exposed-modules: DjinnPlugin, DjinnBridge
11 |   ghc-options: -Wall
12 | 


--------------------------------------------------------------------------------
/djinn-plugin/DjinnPlugin.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TypeApplications, RecordWildCards #-}
 2 | module DjinnPlugin where
 3 | 
 4 | import GhcPlugins hiding ((<>))
 5 | 
 6 | import TcHoleErrors
 7 | 
 8 | import Constraint
 9 | 
10 | import TcRnMonad
11 | 
12 | import DjinnBridge
13 | 
14 | import ConLike(conLikeWrapId_maybe)
15 | import TcEnv (tcLookup)
16 | import Data.Maybe (catMaybes)
17 | 
18 | import Data.List (sortOn)
19 | 
20 | import qualified Data.Set as Set
21 | 
22 | 
23 | data HolePluginState = HPS { djinnEnv :: Environment
24 |                            , maxSols :: MaxSolutions
25 |                            , microSecs :: Int}
26 | 
27 | setDjinnEnv :: Environment -> HolePluginState -> HolePluginState
28 | setDjinnEnv e (HPS _ sols secs)  = HPS e sols secs
29 | 
30 | initPlugin :: [CommandLineOption] -> TcM (TcRef HolePluginState)
31 | -- We take more than we need since djinn is prone to duplicate solutions...
32 | initPlugin [sols] = newTcRef $ HPS [] (Max (read @Int sols * 10)) (40000 :: Int)
33 | initPlugin _ = newTcRef $ HPS [] (Max 30) (40000 :: Int)
34 | 
35 | 
36 | -- | Adds the current candidates to scope in djinn.
37 | djinnAddToScopeP :: [CommandLineOption] -> TcRef HolePluginState -> CandPlugin
38 | djinnAddToScopeP _ ref _ cands = do
39 |   newEnv <- catMaybes <$> mapM hfLookup cands
40 |   --liftIO $ print $ map (showSDocUnsafe . ppr) newEnv
41 |   updTcRef ref (setDjinnEnv newEnv)
42 |   return cands
43 |   where hfLookup :: HoleFitCandidate -> TcM (Maybe (Name,Type))
44 |         hfLookup hfc = tryTcDiscardingErrs (return Nothing) $ do
45 |           let name = getName hfc
46 |           thing <- tcLookup name
47 |           let thingId = case thing of
48 |                           ATcId {tct_id = i} ->  Just i
49 |                           AGlobal (AnId i)   ->  Just i
50 |                           AGlobal (AConLike con) -> conLikeWrapId_maybe con
51 |                           _ -> Nothing
52 |           case thingId of
53 |             Just i -> return $ Just (name, idType i)
54 |             _ -> return Nothing
55 | 
56 | 
57 | djinnSynthP :: [CommandLineOption] -> TcRef HolePluginState -> FitPlugin
58 | djinnSynthP _ ref TyH{tyHImplics = imps, tyHCt = Just holeCt} fits = do
59 |   HPS {..} <- readTcRef ref
60 |   let wrappedType = foldl wrapTypeWithImplication (ctPred holeCt) imps
61 |   --liftIO $ print $ map (showSDocUnsafe . ppr) djinnEnv
62 |   -- liftIO $ print (showSDocUnsafe . ppr $ wrappedType)
63 |   let splitSols = unwords . words . unwords . lines
64 |       solToHf = RawHoleFit . parens . text
65 |       Max numToShow = maxSols
66 |   sols <- map splitSols <$> djinn True djinnEnv wrappedType maxSols microSecs
67 |           -- We could set '-fdefer-typed-holes'  and load the module here...
68 |           -- modInfo <- moduleInfo <$>
69 |   let djinnSols = map solToHf $
70 |                     take (numToShow `div` 10) $
71 |                       sortOn length $ dedup sols
72 |   return $ djinnSols <> fits
73 | djinnSynthP _ _ _ _ = return []
74 | 
75 | -- Lazily de-duplicate a list
76 | dedup :: Ord a => [a] -> [a]
77 | dedup = dedup' Set.empty
78 |   where dedup' sofar (x:xs) | x `Set.member` sofar = dedup' sofar xs
79 |         dedup' sofar (x:xs) = x:dedup' (x `Set.insert` sofar) xs
80 |         dedup' _ [] = []
81 | 
82 | 
83 | 
84 | plugin :: Plugin
85 | plugin = defaultPlugin { holeFitPlugin = holeFitP, pluginRecompile = purePlugin}
86 | 
87 | holeFitP :: [CommandLineOption] -> Maybe HoleFitPluginR
88 | holeFitP opts = Just (HoleFitPluginR initP pluginDef stopP)
89 |   where initP = initPlugin opts
90 |         stopP = const $ return ()
91 |         pluginDef ref = HoleFitPlugin { candPlugin = djinnAddToScopeP opts ref
92 |                                       , fitPlugin  = djinnSynthP opts ref }
93 | 


--------------------------------------------------------------------------------
/djinn-plugin/README.md:
--------------------------------------------------------------------------------
  1 | Djinn Plugin
  2 | =================
  3 | 
  4 | 
  5 | This hole plugin shows how `djinn` can be invoked by a hole fit plugin to synthesize simple programs.
  6 | 
  7 | `DjinnBridge` is based on the `djinn-ghc` package by Alejandro Serrano but modified to use `TcM` directly.
  8 | 
  9 | Note! Needs GHC 8.10
 10 | 
 11 | Example Output
 12 | -----------------
 13 | 
 14 | Using this plugin, you can compile the following:
 15 | 
 16 | ```haskell
 17 | {-# OPTIONS -fplugin=DjinnPlugin -funclutter-valid-hole-fits #-}
 18 | module Main where
 19 | 
 20 | f :: a  -> a
 21 | f = _
 22 | 
 23 | g :: a -> b -> b
 24 | g = _
 25 | 
 26 | i :: (a,b) -> a
 27 | i = _
 28 | 
 29 | j :: a -> a -> a
 30 | j = _
 31 | 
 32 | 
 33 | main :: IO ()
 34 | main = return ()
 35 | ```
 36 | 
 37 | 
 38 | And get the following output:
 39 | 
 40 | ```
 41 | Main.hs:5:5: error:
 42 |     • Found hole: _ :: a -> a
 43 |       Where: ‘a’ is a rigid type variable bound by
 44 |                the type signature for:
 45 |                  f :: forall a. a -> a
 46 |                at Main.hs:4:1-12
 47 |     • In the expression: _
 48 |       In an equation for ‘f’: f = _
 49 |     • Relevant bindings include f :: a -> a (bound at Main.hs:5:1)
 50 |       Valid hole fits include
 51 |         (\ a -> a)
 52 |         (\ _ -> head (cycle (([]) ++ ([]))))
 53 |         (\ _ -> id (head (cycle (([]) ++ ([])))))
 54 |         f :: a -> a
 55 |         id :: forall a. a -> a
 56 |   |
 57 | 5 | f = _
 58 |   |     ^
 59 | 
 60 | Main.hs:8:5: error:
 61 |     • Found hole: _ :: a -> b -> b
 62 |       Where: ‘a’, ‘b’ are rigid type variables bound by
 63 |                the type signature for:
 64 |                  g :: forall a b. a -> b -> b
 65 |                at Main.hs:7:1-16
 66 |     • In the expression: _
 67 |       In an equation for ‘g’: g = _
 68 |     • Relevant bindings include g :: a -> b -> b (bound at Main.hs:8:1)
 69 |       Valid hole fits include
 70 |         (\ _ a -> a)
 71 |         (\ _ a -> seq (head (cycle (([]) ++ ([])))) a)
 72 |         (\ _ a -> snd (head (cycle (([]) ++ ([]))), a))
 73 |         g :: a -> b -> b
 74 |         seq :: forall a b. a -> b -> b
 75 |   |
 76 | 8 | g = _
 77 |   |     ^
 78 | 
 79 | Main.hs:11:5: error:
 80 |     • Found hole: _ :: (a, b) -> a
 81 |       Where: ‘b’, ‘a’ are rigid type variables bound by
 82 |                the type signature for:
 83 |                  i :: forall a b. (a, b) -> a
 84 |                at Main.hs:10:1-15
 85 |     • In the expression: _
 86 |       In an equation for ‘i’: i = _
 87 |     • Relevant bindings include
 88 |         i :: (a, b) -> a (bound at Main.hs:11:1)
 89 |       Valid hole fits include
 90 |         (\ (a, _) -> a)
 91 |         (\ _ -> head (cycle (([]) ++ ([]))))
 92 |         (\ _ -> f (head (cycle (([]) ++ ([])))))
 93 |         i :: (a, b) -> a
 94 |         fst :: forall a b. (a, b) -> a
 95 |    |
 96 | 11 | i = _
 97 |    |     ^
 98 | 
 99 | Main.hs:14:5: error:
100 |     • Found hole: _ :: a -> a -> a
101 |       Where: ‘a’ is a rigid type variable bound by
102 |                the type signature for:
103 |                  j :: forall a. a -> a -> a
104 |                at Main.hs:13:1-16
105 |     • In the expression: _
106 |       In an equation for ‘j’: j = _
107 |     • Relevant bindings include
108 |         j :: a -> a -> a (bound at Main.hs:14:1)
109 |       Valid hole fits include
110 |         (\ _ a -> a)
111 |         (\ a _ -> a)
112 |         (\ _ _ -> head (cycle (([]) ++ ([]))))
113 |         j :: a -> a -> a
114 |         g :: forall a b. a -> b -> b
115 |         seq :: forall a b. a -> b -> b
116 |         (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
117 |    |
118 | 14 | j = _
119 |    |     ^
120 | 
121 | ```
122 | 


--------------------------------------------------------------------------------
/djinn-plugin/Test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=DjinnPlugin -fplugin-opt=DjinnPlugin:2
 2 |             -funclutter-valid-hole-fits #-}
 3 | module Main where
 4 | 
 5 | 
 6 | f :: (a,b) -> b
 7 | f = _
 8 | 
 9 | g :: a -> b -> a
10 | g = _
11 | 
12 | 
13 | main :: IO ()
14 | main = return ()
15 | 


--------------------------------------------------------------------------------
/djinn-plugin/Test/Test.cabal:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | executable test
 7 |   default-language: Haskell2010
 8 |   build-depends: base, DjinnPlugin
 9 |   main-is: Main.hs
10 |   ghc-options: -Wall
11 | 


--------------------------------------------------------------------------------
/djinn-plugin/cabal.project:
--------------------------------------------------------------------------------
1 | packages: ./
2 |           ./Test
3 | allow-newer: all
4 | 


--------------------------------------------------------------------------------
/hoogle-plugin/HolePlugin.cabal:
--------------------------------------------------------------------------------
 1 | name: HolePlugin
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | 
 7 | library
 8 |   default-language: Haskell2010
 9 |   build-depends: base, ghc, process
10 |   exposed-modules: HolePlugin
11 |   ghc-options: -Wall
12 | 


--------------------------------------------------------------------------------
/hoogle-plugin/HolePlugin.hs:
--------------------------------------------------------------------------------
 1 | module HolePlugin where
 2 | 
 3 | import GhcPlugins
 4 | 
 5 | import TcHoleErrors
 6 | 
 7 | import Data.List (intersect, stripPrefix)
 8 | import RdrName (importSpecModule)
 9 | 
10 | import Constraint
11 | 
12 | import System.Process
13 | 
14 | plugin :: Plugin
15 | plugin = defaultPlugin { holeFitPlugin = hfp, pluginRecompile = purePlugin }
16 | 
17 | hfp :: [CommandLineOption] -> Maybe HoleFitPluginR
18 | hfp opts = Just (fromPureHFPlugin $ HoleFitPlugin (candP opts) (fp opts))
19 | 
20 | toFilter :: Maybe String -> Maybe String
21 | toFilter = flip (>>=) (stripPrefix "_module_")
22 | 
23 | replace :: Eq a => a -> a -> [a] -> [a]
24 | replace match repl str = replace' [] str
25 |   where
26 |     replace' sofar (x:xs) | x == match = replace' (repl:sofar) xs
27 |     replace' sofar (x:xs) = replace' (x:sofar) xs
28 |     replace' sofar [] = reverse sofar
29 | 
30 | -- | This candidate plugin filters the candidates by module,
31 | --   using the name of the hole as module to search in
32 | candP :: [CommandLineOption] -> CandPlugin
33 | candP _ hole cands =
34 |   do let he = case tyHCt hole of
35 |                 Just (CHoleCan _ h ExprHole) -> Just (occNameString h)
36 |                 _ -> Nothing
37 |      case toFilter he of
38 |         Just undscModName -> do let replaced = replace '_' '.' undscModName
39 |                                 let res = filter (greNotInOpts [replaced]) cands
40 |                                 return $ res 
41 |         _ -> return cands
42 |   where greNotInOpts opts (GreHFCand gre)  = not $ null $ intersect (inScopeVia gre) opts
43 |         greNotInOpts _ _ = True
44 |         inScopeVia = map (moduleNameString . importSpecModule) . gre_imp
45 | 
46 | -- Yes, it's pretty hacky, but it is just an example :)
47 | searchHoogle :: String -> IO [String]
48 | searchHoogle ty = lines <$> (readProcess "hoogle" [(show ty)] [])
49 | 
50 | fp :: [CommandLineOption] -> FitPlugin
51 | fp ("hoogle":[]) hole hfs =
52 |     do dflags <- getDynFlags
53 |        let tyString = showSDoc dflags . ppr . ctPred <$> tyHCt hole
54 |        res <- case tyString of
55 |                 Just ty -> liftIO $ searchHoogle ty
56 |                 _ -> return []
57 |        return $ (take 2 $ map (RawHoleFit . text . ("Hoogle says: " ++)) res) ++ hfs
58 | fp _ _ hfs = return hfs
59 | 


--------------------------------------------------------------------------------
/hoogle-plugin/README.md:
--------------------------------------------------------------------------------
 1 | Hoogle Plugin
 2 | =================
 3 | 
 4 | Note! Needs GHC 8.10
 5 | 
 6 | An example of a hole fit plugin for GHC that can filter by module and searches the local Hoogle for fits (if hoogle is available, and the
 7 | `-fplugin-opt=HolePlugin:hoogle` is set).
 8 | 
 9 | make sure that `hoogle` is installed (for demo of hoogle features)
10 | and that the local hoogle database has been generated (with `hoogle generate`)
11 | 
12 | then, build with
13 | 
14 | ```
15 |   cabal new-build test
16 | ```
17 | 
18 | and modify `test/Main.hs` to try it out (or run it on your own files).
19 | 
20 | 
21 | 
22 | Example Output:
23 | ---------------
24 | 
25 | 
26 | When run on:
27 | 
28 | ```haskell
29 | {-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:hoogle #-}
30 | -- Make sure to remove the hoogle opt if hoogle is not available locally
31 | module Main where
32 | 
33 | import Prelude hiding (head, last)
34 | 
35 | import Data.List (head, last)
36 | 
37 | t :: [Int] -> Int
38 | t = _module_Prelude
39 | 
40 | g :: [Int] -> Int
41 | g = _module_Data_List
42 | 
43 | main :: IO ()
44 | main = print $ t [1,2,3]
45 | ```
46 | 
47 | the output is:
48 | 
49 | ```
50 | Main.hs:14:5: error:
51 |     • Found hole: _module_Prelude :: [Int] -> Int
52 |       Or perhaps ‘_module_Prelude’ is mis-spelled, or not in scope
53 |     • In the expression: _module_Prelude
54 |       In an equation for ‘t’: t = _module_Prelude
55 |     • Relevant bindings include
56 |         t :: [Int] -> Int (bound at Main.hs:14:1)
57 |       Valid hole fits include
58 |         Hoogle says: GHC.List length :: [a] -> Int
59 |         Hoogle says: GHC.OldList length :: [a] -> Int
60 |         t :: [Int] -> Int (bound at Main.hs:14:1)
61 |         g :: [Int] -> Int (bound at Main.hs:17:1)
62 |         length :: forall (t :: * -> *) a. Foldable t => t a -> Int
63 |           with length @[] @Int
64 |           (imported from ‘Prelude’ at Main.hs:5:1-34
65 |            (and originally defined in ‘Data.Foldable’))
66 |         maximum :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
67 |           with maximum @[] @Int
68 |           (imported from ‘Prelude’ at Main.hs:5:1-34
69 |            (and originally defined in ‘Data.Foldable’))
70 |         (Some hole fits suppressed; use -fmax-valid-hole-fits=N or -fno-max-valid-hole-fits)
71 |    |
72 | 14 | t = _module_Prelude
73 |    |     ^^^^^^^^^^^^^^^
74 | 
75 | Main.hs:17:5: error:
76 |     • Found hole: _module_Data_List :: [Int] -> Int
77 |       Or perhaps ‘_module_Data_List’ is mis-spelled, or not in scope
78 |     • In the expression: _module_Data_List
79 |       In an equation for ‘g’: g = _module_Data_List
80 |     • Relevant bindings include
81 |         g :: [Int] -> Int (bound at Main.hs:17:1)
82 |       Valid hole fits include
83 |         Hoogle says: GHC.List length :: [a] -> Int
84 |         Hoogle says: GHC.OldList length :: [a] -> Int
85 |         g :: [Int] -> Int (bound at Main.hs:17:1)
86 |         head :: forall a. [a] -> a
87 |           with head @Int
88 |           (imported from ‘Data.List’ at Main.hs:7:19-22
89 |            (and originally defined in ‘GHC.List’))
90 |         last :: forall a. [a] -> a
91 |           with last @Int
92 |           (imported from ‘Data.List’ at Main.hs:7:25-28
93 |            (and originally defined in ‘GHC.List’))
94 |    |
95 | 17 | g = _module_Data_List
96 | ```
97 | 


--------------------------------------------------------------------------------
/hoogle-plugin/Test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:hoogle #-}
 2 | -- Make sure to remove the hoogle opt if hoogle is not available locally
 3 | module Main where
 4 | 
 5 | import Prelude hiding (head, last)
 6 | 
 7 | import Data.List (head, last)
 8 | 
 9 | t :: [Int] -> Int
10 | t = _module_Prelude
11 | 
12 | g :: [Int] -> Int
13 | g = _module_Data_List
14 | 
15 | main :: IO ()
16 | main = print $ t [1,2,3]
17 | 


--------------------------------------------------------------------------------
/hoogle-plugin/Test/test.cabal:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | executable test
 7 |   default-language: Haskell2010
 8 |   build-depends: base, ghc, HolePlugin
 9 |   main-is: Main.hs
10 |   ghc-options: -Wall
11 | 


--------------------------------------------------------------------------------
/hoogle-plugin/cabal.project:
--------------------------------------------------------------------------------
1 | packages: ./
2 |           ./Test
3 | 


--------------------------------------------------------------------------------
/hplus-plugin/HPlusPlugin.cabal:
--------------------------------------------------------------------------------
 1 | name: HPlusPlugin
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | 
 7 | library
 8 |   default-language: Haskell2010
 9 |   build-depends: base, ghc, process
10 |   exposed-modules: HPlusPlugin
11 |   ghc-options: -Wall
12 | 


--------------------------------------------------------------------------------
/hplus-plugin/HPlusPlugin.hs:
--------------------------------------------------------------------------------
 1 | module HPlusPlugin where
 2 | 
 3 | import GhcPlugins
 4 | 
 5 | import TcHoleErrors
 6 | 
 7 | import Constraint (ctPred)
 8 | 
 9 | import System.Process
10 | 
11 | plugin :: Plugin
12 | plugin = defaultPlugin { holeFitPlugin = hfp, pluginRecompile = purePlugin }
13 | 
14 | hfp :: [CommandLineOption] -> Maybe HoleFitPluginR
15 | hfp opts = Just (fromPureHFPlugin $ HoleFitPlugin (candP opts) (fp opts))
16 | 
17 | -- | This candidate plugin filters the candidates by module,
18 | --   using the name of the hole as module to search in
19 | candP :: [CommandLineOption] -> CandPlugin
20 | candP _ _ _ = return []
21 | 
22 | -- Yes, it's pretty hacky, but it is just an example :)
23 | hPlus :: String -> String -> IO [String]
24 | hPlus hploc ty = lines <$> (readProcess "../lookup" [hploc, ty] [])
25 | 
26 | fp :: [CommandLineOption] -> FitPlugin
27 | fp [hploc] hole hfs =
28 |     do dflags <- getDynFlags
29 |        let tyString = showSDoc dflags . ppr . ctPred <$> tyHCt hole
30 |        res <- case tyString of
31 |                 Just ty -> liftIO $ hPlus hploc ty
32 |                 _ -> return []
33 |        return $ (take 5 $ map (RawHoleFit . text ) res) ++ hfs
34 | fp r _ _ = return $ map (RawHoleFit . text) r
35 | 


--------------------------------------------------------------------------------
/hplus-plugin/README.md:
--------------------------------------------------------------------------------
 1 | # Hoogle Plus Plugin
 2 | 
 3 | This plugin requires you to give an argument to the plugin to where hoogle_plus
 4 | has been installed (and the generate command already run). It then send the
 5 | type to hplus and returns the result as the result. Note that it is very
 6 | brittle, and only works with
 7 | 
 8 | ``` sh
 9 | $ cabal new-build Test/
10 | ```
11 | at the moment.
12 | 
13 | This prints out:
14 | 
15 | ``` sh
16 | Main.hs:6:5: error:
17 |     • Found hole: _ :: (a -> b, a) -> b
18 |       Where: ‘a’, ‘b’ are rigid type variables bound by
19 |                the type signature for:
20 |                  t :: forall a b. (a -> b, a) -> b
21 |                at Main.hs:5:1-23
22 |     • In the expression: _
23 |       In an equation for ‘t’: t = _
24 |     • Relevant bindings include
25 |         t :: (a -> b, a) -> b (bound at Main.hs:6:1)
26 |       Valid hole fits include (Data.Function.$) (fst arg0) (snd arg0)
27 |   |
28 | 6 | t = _
29 |   |     ^
30 | ```
31 | 
32 | See https://github.com/davidmrdavid/hoogle_plus for instructions on how to setup
33 | hoogle plus.
34 | 


--------------------------------------------------------------------------------
/hplus-plugin/Test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=HPlusPlugin -fplugin-opt=HPlusPlugin:/home/tritlo/hoogle_plus #-}
 2 | module Main where
 3 | 
 4 | 
 5 | t :: ((a -> b), a) -> b
 6 | t = _
 7 | 
 8 | main :: IO ()
 9 | main = return ()
10 | 


--------------------------------------------------------------------------------
/hplus-plugin/Test/Test.cabal:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | executable test
 7 |   default-language: Haskell2010
 8 |   build-depends: base, ghc, HPlusPlugin
 9 |   main-is: Main.hs
10 |   ghc-options: -Wall
11 | 


--------------------------------------------------------------------------------
/hplus-plugin/default.nix:
--------------------------------------------------------------------------------
 1 | let
 2 |   unstable = import <unstable> { };
 3 | in
 4 | { nixpkgs ? import <nixpkgs> { } }:
 5 | with nixpkgs;
 6 | let
 7 |   hspkgs = unstable.haskell.packages.ghc8101;
 8 |   pkgs = [
 9 |     hspkgs.ghc
10 |   ];
11 | 
12 | in nixpkgs.stdenv.mkDerivation {
13 |   name = "env";
14 |   buildInputs = pkgs;
15 | }
16 | 


--------------------------------------------------------------------------------
/hplus-plugin/lookup:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env bash
2 | 
3 | cd $1
4 | 
5 | stack exec -- hplus "$2" | grep 'SOLUTION:' | cut -f 1 -d ' ' --complement
6 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/DjinnBridge.hs:
--------------------------------------------------------------------------------
  1 | --- Based on djinn-ghc by Alejandro Serrano, but reworked to use TcM directly.
  2 | 
  3 | {-# LANGUAGE CPP, PatternGuards, BangPatterns #-}
  4 | module DjinnBridge (Environment, MaxSolutions(..), djinn) where
  5 | 
  6 | import Control.Concurrent
  7 | import Control.Concurrent.Async
  8 | import Control.Monad (forM)
  9 | import Data.Set (Set, insert, union, unions, empty, toList)
 10 | 
 11 | import qualified Djinn.HTypes as D
 12 | import qualified Djinn.LJT as D
 13 | 
 14 | import qualified TcEnv as TE
 15 | import TcRnTypes
 16 | import qualified GhcPlugins as GP
 17 | 
 18 | import MonadUtils
 19 | import qualified DataCon as G
 20 | import qualified GHC as G
 21 | import qualified Name as G
 22 | import qualified TyCon as G
 23 | import qualified Type as G
 24 | 
 25 | import Data.Maybe (mapMaybe, catMaybes, isJust)
 26 | 
 27 | 
 28 | data NoExtraInfo = NoExtraInfo
 29 | type HEnvironment1 a = [(D.HSymbol, ([D.HSymbol], D.HType, a))]
 30 | type HEnvironment = HEnvironment1 NoExtraInfo
 31 | 
 32 | getConTs :: G.Type -> Set G.Name
 33 | getConTs t | Just (_, i)  <- G.splitForAllTy_maybe t = getConTs i
 34 | getConTs t | Just (t1,t2) <- G.splitFunTy_maybe t    = getConTs t1 `union` getConTs t2
 35 | getConTs t | Just t1 <- G.splitListTyConApp_maybe t = getConTs t1
 36 | getConTs t | Just (c, ts) <- G.splitTyConApp_maybe t =
 37 |   let args = unions $ map getConTs ts
 38 |   in if G.isTupleTyCon c then args else insert (G.getName c) args
 39 | getConTs t | Just (t1,t2) <- G.splitAppTy_maybe t    = getConTs t1 `union` getConTs t2
 40 | getConTs t | Just _       <- G.getTyVar_maybe t      = empty
 41 | getConTs _                                           = empty
 42 | 
 43 | mbHType :: G.Type -> Maybe D.HType
 44 | mbHType t | Just (_, i)  <- G.splitForAllTy_maybe t = mbHType  i
 45 | mbHType t | Just (t1,t2) <- G.splitFunTy_maybe t    = do ht1 <- mbHType t1
 46 |                                                          ht2 <- mbHType t2
 47 |                                                          return $ D.HTArrow ht1 ht2
 48 | mbHType t | Just (c, ts) <- G.splitTyConApp_maybe t = do
 49 |               args <- mapM mbHType ts
 50 |               if G.isTupleTyCon c  -- Check if we have a tuple
 51 |                 then if not (null args)
 52 |                      then Just $ D.HTTuple args
 53 |                      -- The unit constructor () is also a tupeTyCon, but this case
 54 |                      -- causes the show instance in Djinn to fail, so we drop it.
 55 |                      else Nothing
 56 |                 else Just $ createHTApp (G.getOccString c) (reverse args)
 57 |   where createHTApp n []     = D.HTCon n
 58 |         createHTApp n (x:xs) = D.HTApp (createHTApp n xs) x
 59 | mbHType t | Just (t1,t2) <- G.splitAppTy_maybe t  = do ht1 <- mbHType t1
 60 |                                                        ht2 <- mbHType t2
 61 |                                                        return $ D.HTApp ht1 ht2
 62 | mbHType t | Just var <- G.getTyVar_maybe t          = Just $ D.HTVar (toHSymbol var)
 63 | mbHType _                                           = Nothing
 64 | 
 65 | environment :: G.Type -> TcM HEnvironment
 66 | environment ty = do
 67 |   let tyConTs = getConTs ty
 68 |   concat <$> mapM environment1 (toList tyConTs)
 69 | 
 70 | environment1 :: G.Name -> TcM HEnvironment
 71 | environment1 name = do
 72 |   thing <- TE.tcLookupGlobal name
 73 |   case thing of
 74 |     G.ATyCon tycon | G.isAlgTyCon tycon -> do
 75 |       let tyconName = toHSymbol $ G.tyConName tycon
 76 |           varsH = map toHSymbol $ G.tyConTyVars tycon
 77 |           Just datacons = G.tyConDataCons_maybe tycon
 78 |       dtypes <- forM datacons $ \dcon -> do
 79 |         let dconN = toHSymbol $ G.dataConName dcon
 80 |             (_,_,dconT,_) = G.dataConSig dcon
 81 |         dconE <- mapM environment dconT
 82 |         return $ do dconTTys <- mapM mbHType dconT
 83 |                     return ((dconN, dconTTys), dconE)
 84 |       return $ if all isJust dtypes
 85 |                then let dtypesT = map fst $ catMaybes dtypes
 86 |                         dtypesE = concatMap snd $ catMaybes dtypes
 87 |                     in (tyconName, (varsH, D.HTUnion dtypesT, NoExtraInfo)) : concat dtypesE
 88 |                else []
 89 |     G.ATyCon tycon | G.isTypeSynonymTyCon tycon -> do
 90 |       -- Get information for this type synonym
 91 |       let tyconName = toHSymbol $ G.tyConName tycon
 92 |           Just (vars, defn) = G.synTyConDefn_maybe tycon
 93 |           varsH = map toHSymbol vars
 94 |       -- Recursively obtain it for the environment of the type
 95 |       case mbHType defn of
 96 |         Just htype -> do defnEnv <- environment defn
 97 |                          return $ (tyconName, (varsH, htype, NoExtraInfo)) : defnEnv
 98 |         _ -> return []
 99 |     _ -> return []
100 |     --         return []
101 | 
102 | toHSymbol :: G.NamedThing a => a -> D.HSymbol
103 | toHSymbol = G.getOccString
104 | 
105 | toLJTSymbol :: G.NamedThing a => a -> D.Symbol
106 | toLJTSymbol = D.Symbol . G.getOccString
107 | 
108 | -- |Bindings which are in scope at a specific point.
109 | type Environment = [(G.Name, G.Type)]
110 | 
111 | -- |Obtain a maximum number of solutions.
112 | newtype MaxSolutions = Max Int
113 | 
114 | 
115 | -- |Obtain the list of expressions which could fill
116 | -- something with the given type.
117 | -- The first flag specifies whether to return one
118 | -- or more solutions to the problem.
119 | djinn :: Bool -> Environment -> G.Type -> MaxSolutions -> Int -> TcM [String]
120 | djinn multi env ty (Max mx) microsec = do
121 |   tyEnv <- environment ty
122 |   case mbHType ty of
123 |     Just hT -> let form = D.hTypeToFormula tyEnv hT
124 |                    toEnvF (n, t) =
125 |                       case mbHType t of
126 |                         Just ht -> Just (toLJTSymbol n, D.hTypeToFormula tyEnv ht)
127 |                         _ -> Nothing
128 |                    envF = mapMaybe toEnvF env
129 |                    prfs = D.prove multi envF form
130 |                    trms =  map (D.hPrExpr . D.termToHExpr ) prfs
131 |                in liftIO $ cropList trms microsec mx (\x -> GP.lengthLessThan x 1000)
132 |     _ -> return []
133 | 
134 | cropList :: [a] -> Int -> Int -> (a -> Bool) -> IO [a]
135 | cropList _   _  0 _ = return []
136 | cropList lst ms n chk =
137 |   withAsync (let !l = lst in return l) $ \a -> do
138 |     threadDelay ms
139 |     res <- poll a
140 |     case res of
141 |       Just r -> case r of
142 |         Right (x:xs) -> if chk x then do ys <- cropList xs ms (n-1) chk
143 |                                          return $ x : ys
144 |                                  else return []
145 |         _            -> return []
146 |       Nothing -> do cancel a
147 |                     return []
148 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/NonEmptyHolesPlugin.cabal:
--------------------------------------------------------------------------------
 1 | name: NonEmptyHolesPlugin
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | 
 7 | library
 8 |   default-language: Haskell2010
 9 |   build-depends: base, ghc, time, djinn-lib, containers, async, process, template-haskell, mtl
10 |   exposed-modules: NonEmptyHolesPlugin, DjinnBridge
11 |   ghc-options: -Wall
12 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/NonEmptyHolesPlugin.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE TypeApplications, RecordWildCards, DeriveDataTypeable, MagicHash #-}
  2 | module NonEmptyHolesPlugin where
  3 | 
  4 | import GhcPlugins hiding ((<>), getSrcSpanM)
  5 | 
  6 | import TcHoleErrors
  7 | 
  8 | 
  9 | import TcRnTypes
 10 | 
 11 | import TcRnMonad
 12 | 
 13 | import DjinnBridge
 14 | 
 15 | import ConLike(conLikeWrapId_maybe)
 16 | import TcEnv (tcLookup)
 17 | import Data.Maybe (catMaybes)
 18 | 
 19 | import Data.List (sortOn)
 20 | 
 21 | import qualified Data.Set as Set
 22 | 
 23 | import Data.List (intersect)
 24 | 
 25 | import System.Process
 26 | 
 27 | import HsExpr
 28 | 
 29 | import Language.Haskell.TH hiding (ppr, Type, Name)
 30 | 
 31 | import Data.Data
 32 | 
 33 | import Data.Char (isSpace)
 34 | 
 35 | import HsExtension (GhcTc, GhcPs)
 36 | import Data.Dynamic
 37 | 
 38 | import qualified Control.Monad.State.Lazy as St
 39 | import Control.Monad.State.Lazy (State)
 40 | 
 41 | import Data.Sequence (Seq)
 42 | import qualified Data.Sequence as Seq
 43 | 
 44 | import Data.Foldable (toList)
 45 | 
 46 | import Language.Haskell.TH.Syntax (liftData, unsafeTExpCoerce)
 47 | 
 48 | 
 49 | type Cmd = State (Seq PluginType)
 50 | 
 51 | invoke :: PluginType -> Cmd ()
 52 | invoke t = St.modify (flip (Seq.|>) t)
 53 | 
 54 | filterBy :: String -> Cmd ()
 55 | filterBy str = St.modify (flip (Seq.|>) (Mod str))
 56 | 
 57 | boo :: Bool -> Cmd Bool
 58 | boo = return
 59 | 
 60 | pfp :: String -> Cmd ()
 61 | pfp = error
 62 | 
 63 | execTyped :: Cmd () -> Q (TExp [PluginType])
 64 | execTyped cmds = unsafeTExpCoerce $ liftData $ toList $ St.execState cmds Seq.empty
 65 | 
 66 | exec :: Cmd () -> Q Exp
 67 | exec cmds = unType <$> (execTyped cmds)
 68 | 
 69 | 
 70 | data HolePluginState = HPS { djinnEnv :: Environment
 71 |                            , maxSols :: MaxSolutions
 72 |                            , microSecs :: Int}
 73 | 
 74 | setDjinnEnv :: Environment -> HolePluginState -> HolePluginState
 75 | setDjinnEnv e (HPS _ sols secs)  = HPS e sols secs
 76 | 
 77 | initPlugin :: [CommandLineOption] -> TcM (TcRef HolePluginState)
 78 | -- We take more than we need since djinn is prone to duplicate solutions...
 79 | initPlugin _ = newTcRef $ HPS [] (Max 20) (40000 :: Int)
 80 | 
 81 | trim :: String -> String
 82 | trim = reverse . dropWhile isSpace . reverse .  dropWhile isSpace
 83 | 
 84 | 
 85 | -- | Adds the current candidates to scope in djinn.
 86 | djinnAddToScopeP :: TcRef HolePluginState -> CandPlugin
 87 | djinnAddToScopeP ref _ cands = do
 88 |   newEnv <- catMaybes <$> mapM hfLookup cands
 89 |   --liftIO $ print $ map (showSDocUnsafe . ppr) newEnv
 90 |   updTcRef ref (setDjinnEnv newEnv)
 91 |   return cands
 92 |   where hfLookup :: HoleFitCandidate -> TcM (Maybe (Name,Type))
 93 |         hfLookup hfc = tryTcDiscardingErrs (return Nothing) $ do
 94 |           let name = getName hfc
 95 |           thing <- tcLookup name
 96 |           let thingId = case thing of
 97 |                           ATcId {tct_id = i} ->  Just i
 98 |                           AGlobal (AnId i)   ->  Just i
 99 |                           AGlobal (AConLike con) -> conLikeWrapId_maybe con
100 |                           _ -> Nothing
101 |           case thingId of
102 |             Just i -> return $ Just (name, idType i)
103 |             _ -> return Nothing
104 | 
105 | 
106 | djinnSynthP :: TcRef HolePluginState -> FitPlugin
107 | djinnSynthP ref TyH{tyHImplics = imps, tyHCt = Just holeCt} fits = do
108 |   HPS {..} <- readTcRef ref
109 |   let wrappedType = foldl wrapTypeWithImplication (ctPred holeCt) imps
110 |   --liftIO $ print $ map (showSDocUnsafe . ppr) djinnEnv
111 |   -- liftIO $ print (showSDocUnsafe . ppr $ wrappedType)
112 |   let splitSols = unwords . words . unwords . lines
113 |       solToHf = RawHoleFit . parens . text
114 |       Max numToShow = maxSols
115 |   sols <- map splitSols <$> djinn True djinnEnv wrappedType maxSols microSecs
116 |           -- We could set '-fdefer-typed-holes'  and load the module here...
117 |           -- modInfo <- moduleInfo <$>
118 |   let djinnSols = map solToHf $
119 |                     take (numToShow `div` 10) $
120 |                       sortOn length $ dedup sols
121 |   return $ djinnSols <> fits
122 | djinnSynthP _ _ _ = return []
123 | 
124 | -- Lazily de-duplicate a list
125 | dedup :: Ord a => [a] -> [a]
126 | dedup = dedup' Set.empty
127 |   where dedup' sofar (x:xs) | x `Set.member` sofar = dedup' sofar xs
128 |         dedup' sofar (x:xs) = x:dedup' (x `Set.insert` sofar) xs
129 |         dedup' _ [] = []
130 | 
131 | 
132 | data PluginType = Djinn 
133 |                 | Hoogle
134 |                 | Mod String
135 |                 | Discard
136 |                 deriving (Eq, Show, Data, Typeable)
137 | 
138 | toPluginType :: Maybe String -> [PluginType]
139 | toPluginType (Just holeContent) = map toT spl
140 |   where spl = split '&' holeContent
141 |         toT c = case (trim c) of
142 |                 "invoke djinn" -> Djinn
143 |                 "invoke hoogle" -> Hoogle
144 |                 'f':'i':'l':'t':'e':'r':'B':'y':' ':rest -> Mod rest
145 |                 _ -> error $ show $ trim c
146 | toPluginType _ = []
147 | 
148 | 
149 | 
150 | getCommands :: TypedHole -> TcM [PluginType]
151 | getCommands hole = recoverM (return [Discard]) $ do
152 |                     case hexpr of
153 |                         Just (Left lexpr) ->
154 |                           do dv <- runEHRExprDyn lexpr
155 |                              return $ fromDyn dv (error $ show $ dynTypeRep dv ) -- showSDocUnsafe $ ppr lexpr) 
156 |                         Just (Right lexpr) ->
157 |                           do dv <- runEHSplice lexpr
158 |                              return $ fromDyn dv (error $ showSDocUnsafe $ ppr lexpr) 
159 |                         _ -> return []
160 |  where hexpr = getHoleExpr hole
161 | 
162 | djinnHoogleModCP :: TcRef HolePluginState -> CandPlugin
163 | djinnHoogleModCP ref hole candidates = do
164 |   commands <- getCommands hole
165 |   foldl (>>=) (return candidates) $ map action commands
166 |   where greNotInOpts opts (GreHFCand gre) = not $ null $ intersect (inScopeVia gre) opts
167 |         greNotInOpts _ _ = True
168 |         inScopeVia = map (moduleNameString . importSpecModule) . gre_imp
169 |         action ty cands = case ty of
170 |                             -- Pass to the Djinn plugin
171 |                             Djinn -> djinnAddToScopeP ref hole cands
172 |                             -- Filter by where the elemnet comes from 
173 |                             Mod modName -> return $ filter (greNotInOpts [modName]) cands
174 |                             Discard -> return []
175 |                             _ -> return cands
176 | 
177 | plugin :: Plugin
178 | plugin = defaultPlugin { holeFitPlugin = holeFitP, pluginRecompile = purePlugin}
179 | 
180 | holeFitP :: [CommandLineOption] -> Maybe HoleFitPluginR
181 | holeFitP opts = Just (HoleFitPluginR initP pluginDef stopP)
182 |   where initP = initPlugin opts
183 |         stopP = const $ return ()
184 |         pluginDef ref = HoleFitPlugin { candPlugin = djinnHoogleModCP ref
185 |                                       , fitPlugin  = djinnHoogleModFP ref }
186 | 
187 | getHoleExpr :: TypedHole -> Maybe (Either (LHsExpr GhcPs) (LHsExpr GhcTc))
188 | getHoleExpr hole = 
189 |     case tyHCt hole of
190 |         Just (CHoleCan _ (NonEmptyExprHole _ (EHRExpr e))) -> Just $ Left e
191 |         Just (CHoleCan _ (NonEmptyExprHole _ (EHRSplice spl))) -> Just $ Right spl
192 |         _ -> Nothing
193 | 
194 | djinnHoogleModFP :: TcRef HolePluginState -> FitPlugin
195 | djinnHoogleModFP ref hole fits =
196 |   do commands <- getCommands hole
197 |      foldl (>>=) (return fits) $ map action commands
198 |   where action ty hfs  = case ty of
199 |                            Djinn -> djinnSynthP ref hole hfs
200 |                            Hoogle -> hoogleFP hole hfs
201 |                            Discard -> return []
202 |                            _ -> return hfs
203 | 
204 | 
205 | searchHoogle :: String -> IO [String]
206 | searchHoogle ty = lines <$> (readProcess "hoogle" [(show ty)] [])
207 | 
208 | hoogleFP :: FitPlugin
209 | hoogleFP hole hfs =
210 |     do dflags <- getDynFlags
211 |        let tyString = showSDoc dflags . ppr . ctPred <$> tyHCt hole
212 |        res <- case tyString of
213 |                 Just ty -> liftIO $ searchHoogle ty
214 |                 _ -> return []
215 |        return $ (take 2 $ map (RawHoleFit . text . ("Hoogle: " ++)) res) ++ hfs
216 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/README.md:
--------------------------------------------------------------------------------
 1 | The Non-Empty Holes Plugin
 2 | =================
 3 | 
 4 | The Non-Empty Holes Plugin showcases how the new non-empty holes allows you
 5 | to communicate with plugins.
 6 |  
 7 | `DjinnBridge` is based on the `djinn-ghc` package by Alejandro Serrano but modified to use `TcM` directly.
 8 | 
 9 | Note! Needs a freshly built GHC from merge request [!1766](https://gitlab.haskell.org/ghc/ghc/merge_requests/1766) on GitLab.
10 | 
11 | Example Output
12 | -----------------
13 | 
14 | Using this plugin, you can compile the following (using `cabal new-build test` with a freshly built GHC HEAD):
15 | 
16 | ```haskell
17 | 
18 | {-# OPTIONS -fplugin=NonEmptyHolesPlugin -funclutter-valid-hole-fits #-}
19 | {-# LANGUAGE TemplateHaskell #-}
20 | {-# LANGUAGE NonEmptyTypedHoles #-}
21 | module Main where
22 | import NonEmptyHolesPlugin
23 | import Control.Monad
24 | import Language.Haskell.TH.Syntax (liftData)
25 | 
26 | f :: (a,b) -> a
27 | f = _("invoke hoogle & filterBy Prelude & invoke djinn")
28 | 
29 | g :: (a,b) -> b
30 | g = _$( exec $ do
31 |         invoke Hoogle
32 |         filterBy "Control.Monad"
33 |         invoke Djinn)
34 | 
35 | main = return ()
36 | ```
37 | 
38 | 
39 | And get the following output:
40 | 
41 | ```
42 | 
43 | Main.hs:10:5: error:
44 |     • Found hole: _(...) :: (a, b) -> a
45 |       Where: ‘b’, ‘a’ are rigid type variables bound by
46 |                the type signature for:
47 |                  f :: forall a b. (a, b) -> a
48 |                at Main.hs:9:1-15
49 |       Or perhaps ‘_(...)’ is mis-spelled, or not in scope
50 |     • In the expression: _(...)
51 |       In an equation for ‘f’: f = _(...)
52 |     • Relevant bindings include
53 |         f :: (a, b) -> a (bound at Main.hs:10:1)
54 |       Valid hole fits include
55 |         (\ (a, _) -> a)
56 |         (\ _ -> head (cycle (([]) ++ ([]))))
57 |         Hoogle: Prelude fst :: (a, b) -> a
58 |         Hoogle: Data.Tuple fst :: (a, b) -> a
59 |         f :: (a, b) -> a
60 |         fst :: forall a b. (a, b) -> a
61 |    |
62 | 10 | f = _("invoke hoogle & filterBy Prelude & invoke djinn")
63 |    |     ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
64 | 
65 | Main.hs:13:5: error:
66 |     • Found hole: _$(...) :: (a, b) -> b
67 |       Where: ‘a’, ‘b’ are rigid type variables bound by
68 |                the type signature for:
69 |                  g :: forall a b. (a, b) -> b
70 |                at Main.hs:12:1-15
71 |       Or perhaps ‘_$(...)’ is mis-spelled, or not in scope
72 |     • In the expression: _$(...)
73 |       In an equation for ‘g’: g = _$(...)
74 |     • Relevant bindings include
75 |         g :: (a, b) -> b (bound at Main.hs:13:1)
76 |       Valid hole fits include
77 |         (\ (_, a) -> a)
78 |         Hoogle: Prelude fst :: (a, b) -> a
79 |         Hoogle: Data.Tuple fst :: (a, b) -> a
80 |         g :: (a, b) -> b
81 |    |
82 | 13 | g = _$( exec $ do
83 |    |     ^^^^^^^^^^^^^...
84 | ```
85 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/Test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=NonEmptyHolesPlugin -funclutter-valid-hole-fits #-}
 2 | {-# LANGUAGE TemplateHaskell #-}
 3 | {-# LANGUAGE NonEmptyTypedHoles #-}
 4 | module Main where
 5 | import NonEmptyHolesPlugin
 6 | import Control.Monad
 7 | import Data.Dynamic
 8 | import Data.Typeable
 9 | 
10 | f :: (a,b) -> a
11 | f = _([Hoogle])
12 | 
13 | g :: (a,b) -> b
14 | g = _$( exec $ do
15 |         invoke Hoogle
16 |         filterBy "Control.Monad"
17 |         invoke Djinn)
18 | 
19 | h :: (a,b) -> b
20 | h = _$$( execTyped $ do
21 |         invoke Hoogle
22 |         filterBy "Control.Monad"
23 |         invoke Djinn)
24 | 
25 | 
26 | data A = A | B | C
27 | 
28 | b :: A
29 | b = A
30 | 
31 | j :: ()
32 | j = _([A,b])
33 | 
34 | main = return ()
35 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/Test/Test.cabal:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | executable test
 7 |   default-language: Haskell2010
 8 |   build-depends: base, NonEmptyHolesPlugin, template-haskell, ghc
 9 |   main-is: Main.hs
10 |   ghc-options: -Wall
11 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/Test/out:
--------------------------------------------------------------------------------
1 | Build profile: -w ghc-8.9.0.20190624 -O1
2 | In order, the following will be built (use -v for more details):
3 |  - Test-1.0.0 (exe:test) (file Main.hs changed)
4 | Preprocessing executable 'test' for Test-1.0.0..
5 | Building executable 'test' for Test-1.0.0..
6 | [1 of 1] Compiling Main             ( Main.hs, /home/tritlo/Code/new-hole-plugin/djinn-hoogle-mod-plugin/dist-newstyle/build/x86_64-linux/ghc-8.9.0.20190624/Test-1.0.0/x/test/build/test/test-tmp/Main.o )
7 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/Test/stdin:
--------------------------------------------------------------------------------
 1 | 
 2 | Main.hs:5:5: error:
 3 |     • Found hole: _invoke_Djinn :: [a] -> [[a]]
 4 |       Where: ‘a’ is a rigid type variable bound by
 5 |                the type signature for:
 6 |                  f :: forall a. [a] -> [[a]]
 7 |                at Main.hs:4:1-17
 8 |       Or perhaps ‘_invoke_Djinn’ is mis-spelled, or not in scope
 9 |     • In the expression: _invoke_Djinn
10 |       In an equation for ‘f’: f = _invoke_Djinn
11 |     • Relevant bindings include
12 |         f :: [a] -> [[a]] (bound at Main.hs:5:1)
13 |       Valid hole fits include
14 |         f :: [a] -> [[a]]
15 |         repeat :: forall a. a -> [a]
16 |         return :: forall (m :: * -> *) a. Monad m => a -> m a
17 |         pure :: forall (f :: * -> *) a. Applicative f => a -> f a
18 |         mempty :: forall a. Monoid a => a
19 |   |
20 | 5 | f = _invoke_Djinn
21 |   |     ^^^^^^^^^^^^^
22 | 


--------------------------------------------------------------------------------
/non-empty-holes-plugin/cabal.project:
--------------------------------------------------------------------------------
 1 | packages: ./
 2 |           ./Test
 3 | with-compiler: /home/tritlo/Code/gitlab-ghc/_build/stage1/bin/ghc
 4 | --with-compiler: /home/tritlo/Code/ghc-bindist/ghc-8.9.0.20190819/new-bin/bin/ghc
 5 | 
 6 | 
 7 | allow-newer: all
 8 | 
 9 | repository head.hackage
10 |   url: http://head.hackage.haskell.org/
11 |   secure: True
12 |   root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740
13 |              2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb
14 |              8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e
15 |   key-threshold: 3 
16 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/HolePlugin.cabal:
--------------------------------------------------------------------------------
 1 | name: HolePlugin
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | 
 7 | library
 8 |   default-language: Haskell2010
 9 |   build-depends: base, ghc, process, QuickCheck, text, hashable
10 |   exposed-modules: HolePlugin, Test.ProgInput, Test.FindFit
11 |   ghc-options: -Wall
12 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/HolePlugin.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE RecordWildCards #-}
  2 | module HolePlugin where
  3 | 
  4 | import GhcPlugins
  5 | 
  6 | import TcHoleErrors
  7 | 
  8 | import Data.List (intersect, stripPrefix)
  9 | import RdrName (importSpecModule)
 10 | 
 11 | import Constraint
 12 | 
 13 | import System.Process
 14 | 
 15 | import Data.Maybe (mapMaybe)
 16 | 
 17 | import TcRnMonad
 18 | 
 19 | import Json
 20 | 
 21 | import Test.ProgInput
 22 | 
 23 | import Data.Hashable
 24 | 
 25 | plugin :: Plugin
 26 | plugin = defaultPlugin { holeFitPlugin = hfp, pluginRecompile = purePlugin }
 27 | 
 28 | hfp :: [CommandLineOption] -> Maybe HoleFitPluginR
 29 | hfp opts = Just (fromPureHFPlugin $ HoleFitPlugin (candP opts) (fp opts))
 30 | 
 31 | 
 32 | toHoleFitCommand :: TypedHole -> Maybe String
 33 | toHoleFitCommand (TyH{tyHCt = Just (CHoleCan _ h)})
 34 |     = stripPrefix "_with_" (occNameString $ holeOcc h)
 35 | toHoleFitCommand _ = Nothing
 36 | 
 37 | holeName :: TypedHole -> Maybe String
 38 | holeName (TyH{tyHCt = Just (CHoleCan _ h)})
 39 |     = Just (occNameString $ holeOcc h)
 40 | holeName _ = Nothing
 41 | 
 42 | -- | This candidate plugin filters the candidates by module,
 43 | --   using the name of the hole as module to search in
 44 | candP :: [CommandLineOption] -> CandPlugin
 45 | candP _ hole cands = do
 46 |      case (toHoleFitCommand hole) of
 47 |         _ -> return cands
 48 | 
 49 | hfName :: HoleFit -> Maybe Name
 50 | hfName hf@(HoleFit {}) = (Just . getName . hfCand) hf
 51 | hfName _ = Nothing
 52 | 
 53 | 
 54 | data PropFilterOut = PFO { hName :: Maybe String,
 55 |                            pName :: String,
 56 |                            hLoc  :: Maybe String,
 57 |                            hFits :: [String]} deriving (Show)
 58 | 
 59 | data ShouldFilterOut = SFO { shName :: Maybe String,
 60 |                              spName :: String,
 61 |                              shLoc  :: Maybe String,
 62 |                              shFits :: [String]} deriving (Show)
 63 | 
 64 | 
 65 | fromMaybeNull :: Maybe String -> JsonDoc
 66 | fromMaybeNull (Just s) = JSString s
 67 | fromMaybeNull _ = JSNull
 68 | 
 69 | 
 70 | hFile :: TypedHole -> Maybe String
 71 | hFile (TyH { tyHCt = Just (CHoleCan ev _)}) =
 72 |    Just (unpackFS (srcSpanFile $ ctLocSpan (ctev_loc ev )))
 73 | hFile _ = Nothing
 74 | 
 75 | propFilterFP :: String -> String -> FitPlugin
 76 | propFilterFP fn name hole fits =
 77 |   do fs <- getDynFlags
 78 |      mod <- (moduleNameString . moduleName . tcg_mod) <$> getGblEnv
 79 |      liftIO $ do putStrLn ("prop was: " ++ name)
 80 |                  let fstrings = map (showSDoc fs . ppr) $ (mapMaybe hfName fits)
 81 |                      pn = ("prop_" ++ name)
 82 |                      pfo = PFO { hName = holeName hole, pName = pn,
 83 |                                  hLoc = hFile hole, hFits = fstrings}
 84 |                  appendFile fn $ ( Prelude.<> "\n") $ show $ (ProgIn {modN = mod, propN = pn,
 85 |                   fitStrs = fstrings, holeN = holeName hole,
 86 |                   holeL = hFile hole})
 87 |                  return fits
 88 | 
 89 | shouldFilterFP :: String -> String -> FitPlugin
 90 | shouldFilterFP fn name hole fits =
 91 |   do fs <- getDynFlags
 92 |      mod <- (moduleNameString . moduleName . tcg_mod) <$> getGblEnv
 93 |      liftIO $ do putStrLn ("should was: " ++ name)
 94 |                  let fstrings = map (showSDoc fs . ppr) $ (mapMaybe hfName fits)
 95 |                      sfo = SFO { shName = holeName hole, spName = name,
 96 |                                  shLoc = hFile hole, shFits = fstrings}
 97 |                  appendFile fn $ ( Prelude.<> "\n") $ show $
 98 |                     (ProgIn {modN = mod, propN = name,
 99 |                              fitStrs = fstrings, holeN = holeName hole,
100 |                              holeL = hFile hole})
101 |                  return fits
102 |  
103 | fp :: [CommandLineOption] -> FitPlugin
104 | fp [fn] hole hfs = case toHoleFitCommand hole of
105 |                   Just name | Just propName <- stripPrefix "prop_" name ->
106 |                       propFilterFP fn propName hole hfs
107 |                   Just name | Just shouldName <- stripPrefix "should_" name ->
108 |                       shouldFilterFP fn shouldName hole hfs
109 |                   _ -> return hfs
110 | fp _ _ hfs = return hfs
111 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/README.md:
--------------------------------------------------------------------------------
 1 | QuickCheck Plugin
 2 | =================
 3 | 
 4 | Note! Needs a custom branch of GHC [currently in submission](https://phabricator.haskell.org/D5373).
 5 | 
 6 | 
 7 | Example Output:
 8 | ---------------
 9 | 
10 | When you run the script `Test/genFits.hs`
11 | 
12 | When run on:
13 | 
14 | ```haskell
15 | {-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:out.fits -fno-show-type-app-of-hole-fits -fdefer-typed-holes #-}
16 | module Main where
17 | 
18 | import Prelude hiding (head, last)
19 | 
20 | import Data.List (head, last)
21 | 
22 | j :: [Int] -> Int
23 | j = _with_prop_isLength
24 | 
25 | prop_isLength :: ([Int] -> Int) -> Bool
26 | prop_isLength f = f [] == 0 && f [5,6] == 2
27 | 
28 | k :: [Int] -> Int
29 | k = _with_prop_isHead
30 | 
31 | prop_isHead :: ([Int] -> Int) -> [Int] -> Bool
32 | prop_isHead f [] = True
33 | prop_isHead f (x:xs) = (f (x:xs)) == x
34 | 
35 | ```
36 | 
37 | the output is:
38 | 
39 | ```haskell
40 | {-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:out.fits -fno-show-type-app-of-hole-fits -fdefer-typed-holes #-}
41 | module Main where
42 | 
43 | import Prelude hiding (head, last)
44 | 
45 | import Data.List (head, last)
46 | 
47 | j :: [Int] -> Int
48 | j = _with_prop_isLength
49 | 
50 | prop_isLength :: ([Int] -> Int) -> Bool
51 | prop_isLength f = f [] == 0 && f [5,6] == 2
52 | 
53 | k :: [Int] -> Int
54 | k = _with_prop_isHead
55 | 
56 | prop_isHead :: ([Int] -> Int) -> [Int] -> Bool
57 | prop_isHead f [] = True
58 | prop_isHead f (x:xs) = (f (x:xs)) == x
59 | 
60 | 
61 | main :: IO ()
62 | main = print "hey"
63 | _with_prop_isHead = head
64 | _with_prop_isLength = length
65 | 
66 | ```
67 | 
68 | Which has correctly filled the holes in with `head` and `length`.
69 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/FindFit.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE TypeApplications #-}
 2 | {-# LANGUAGE RecordWildCards #-}
 3 | module Test.FindFit where
 4 | 
 5 | import Text.Printf
 6 | import Test.ProgInput
 7 | import Data.List (nub, intercalate, replicate)
 8 | 
 9 | getProgInputs :: FilePath -> IO [ProgInput]
10 | getProgInputs file = map (read @ProgInput) . lines <$> readFile file
11 | 
12 | data ProgOut = ProgO { oHoleL :: Maybe String
13 |                      , oHoleN :: Maybe String
14 |                      , oModN :: String
15 |                      , fits :: [String] } deriving (Show, Read)
16 |                       
17 | 
18 | genFitTestModule :: IO ()
19 | genFitTestModule = do pins <- getProgInputs "out.fits"
20 |                       let mods = map modN pins
21 |                       print pins
22 |                       let prel = unlines $ genProgPrelude mods
23 |                       let fr = genFitReps $ map piToChecks pins
24 |                       let prog = prel ++ fr ++ genMain
25 |                       putStrLn $ prog
26 |                       writeFile "FitTest.hs" prog
27 | 
28 | addToFile :: ProgOut -> IO ()
29 | addToFile (ProgO { oHoleL = Just filename
30 |                  , oHoleN = Just hn
31 |                  , fits = fits})
32 |     = appendFile filename (printf "%s = %s\n" hn res)
33 |          where res = case fits of
34 |                       [] -> "undefined"
35 |                       (f:_) -> f
36 | addToFile _ = return ()
37 | 
38 | addToFiles :: [ProgOut] -> IO ()
39 | addToFiles = mapM_ addToFile
40 | 
41 | 
42 | 
43 | genMain :: Program
44 | genMain = unlines $ ["", "executeFitTest = fitReps >>= addToFiles"]
45 | 
46 | genFitReps :: [Statement] -> Program
47 | genFitReps checks = unlines ["fitReps :: IO [ProgOut]"
48 |                            , "fitReps = " ++ toSeq checks] 
49 | 
50 | piToChecks :: ProgInput -> Statement
51 | piToChecks (ProgIn {..}) = (genChecks propN fitStrs)
52 |                         ++  (printf ">>= (\\r -> return (ProgO {oHoleL = %s, oHoleN = %s, oModN = %s, fits = r}))" (show holeL) (show holeN) (show modN))
53 | 
54 |                               
55 | type PropName = String
56 | type ModName = String
57 | type Fit = String
58 | type Program = String
59 | type Statement = String
60 | 
61 | genProgPrelude :: [ModName] -> [Statement]
62 | genProgPrelude mods = [ "module FitTest where"
63 |                       , "import Test.QuickCheck"
64 |                       , "import Test.FindFit"]
65 |                       ++ (map (printf "import %s") ( nub mods))
66 |                       ++ [""]
67 | 
68 | toSeq :: [Statement] -> Statement
69 | toSeq stmts = "(sequence [" ++ (intercalate "," stmts) ++ "])"
70 | 
71 | genChecks :: PropName -> [Fit] -> Statement
72 | genChecks propName fits = "( (map fst . filter (\\(_,r) -> r)) <$> "
73 |                        ++ (toSeq $  map check fits) ++ ")"
74 |  where 
75 |    check :: String -> String
76 |    check fit = printf "(\\r -> (\"%s\", isSuccess r)) <$> (quickCheckResult (%s %s))" fit propName fit
77 | 
78 | 
79 | 
80 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:out.fits -fno-show-type-app-of-hole-fits -fdefer-typed-holes #-}
 2 | module Main where
 3 | 
 4 | import Prelude hiding (head, last)
 5 | 
 6 | import Data.List (head, last)
 7 | 
 8 | j :: [Int] -> Int
 9 | j = _with_prop_behavesLikeLength
10 | 
11 | prop_behavesLikeLength :: ([Int] -> Int) -> Bool
12 | prop_behavesLikeLength f = f [] == 0 && f [5,6] == 2
13 | 
14 | k :: [Int] -> Int
15 | k = _with_prop_behavesLikeHead
16 | 
17 | prop_behavesLikeHead :: ([Int] -> Int) -> [Int] -> Bool
18 | prop_behavesLikeHead f [] = True
19 | prop_behavesLikeHead f (x:xs) = (f (x:xs)) == x
20 | 
21 | 
22 | main :: IO ()
23 | main = print "hey"
24 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/MainOrig.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS -fplugin=HolePlugin -fplugin-opt=HolePlugin:out.fits -fno-show-type-app-of-hole-fits -fdefer-typed-holes #-}
 2 | module Main where
 3 | 
 4 | import Prelude hiding (head, last)
 5 | 
 6 | import Data.List (head, last)
 7 | 
 8 | j :: [Int] -> Int
 9 | j = _with_prop_behavesLikeLength
10 | 
11 | prop_behavesLikeLength :: ([Int] -> Int) -> Bool
12 | prop_behavesLikeLength f = f [] == 0 && f [5,6] == 2
13 | 
14 | k :: [Int] -> Int
15 | k = _with_prop_behavesLikeHead
16 | 
17 | prop_behavesLikeHead :: ([Int] -> Int) -> [Int] -> Bool
18 | prop_behavesLikeHead f [] = True
19 | prop_behavesLikeHead f (x:xs) = (f (x:xs)) == x
20 | 
21 | 
22 | main :: IO ()
23 | main = print "hey"
24 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/ProgInput.hs:
--------------------------------------------------------------------------------
1 | module Test.ProgInput where
2 | 
3 | data ProgInput = ProgIn { modN :: String,
4 |                           propN :: String,
5 |                           holeN :: Maybe String,
6 |                           holeL :: Maybe String,
7 |                           fitStrs :: [String] } deriving (Show, Read)
8 | 
9 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/genFits.sh:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | cp Main.hs MainOrig.hs
 4 | touch out.fits
 5 | rm -f out.fits
 6 | echo '\n' | ( echo ":load FindFit.hs" \
 7 |             && echo "Test.FindFit.genFitTestModule" \
 8 |             && echo ":load FitTest.hs"\
 9 |             && echo "FitTest.executeFitTest"\
10 |             && echo ":q" \
11 |             && cat ) | cabal new-repl --allow-newer
12 | bat --theme='Monokai Extended Light' Main.hs
13 | cp MainOrig.hs Main.hs
14 | 
15 | 
16 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/genHoles.sh:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env bash
2 | rm test/out.fits
3 | echo "[" >> test/out.fits
4 | cabal new-build test
5 | echo "]" >> test/out.fits
6 | cat test/out.fits
7 | 
8 | 
9 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/Test/test.cabal:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | cabal-version: >= 1.24
 3 | build-type: Simple
 4 | version: 1.0.0
 5 | 
 6 | executable test
 7 |   default-language: Haskell2010
 8 |   build-depends: base, ghc, HolePlugin, QuickCheck, text
 9 |   main-is: Main.hs
10 |   ghc-options: -Wall
11 | 


--------------------------------------------------------------------------------
/quickcheck-plugin/cabal.project:
--------------------------------------------------------------------------------
 1 | packages: ./
 2 |           ./Test
 3 | with-compiler: /home/tritlo/Code/gitlab-ghc/_build/stage1/bin/ghc
 4 | 
 5 | repository head.hackage
 6 |   url: http://head.hackage.haskell.org/
 7 |   secure: True
 8 |   root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740
 9 |              2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb
10 |              8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e
11 |   key-threshold: 3 
12 | 


--------------------------------------------------------------------------------