[WIP] Migrate to Ghc API

cbits/HsVersions.h

@@ -0,0 +1,8 @@
+/* Hack needed because of http://hackage.haskell.org/trac/ghc/ticket/8040 */
+
+#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
+
+#define GLOBAL_VAR(name,value,ty)  \
+{-# NOINLINE name #-};             \
+name :: IORef (ty);                \
+name = Util.global (value);

cbits/PosixSource.h

@@ -0,0 +1,42 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2005
+ *
+ * Include this file into sources which should not need any non-Posix services.
+ * That includes most RTS C sources.
+ * ---------------------------------------------------------------------------*/
+
+#ifndef POSIXSOURCE_H
+#define POSIXSOURCE_H
+
+#include <ghcplatform.h>
+
+#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS)
+#define _POSIX_C_SOURCE 200112L
+#define _XOPEN_SOURCE   600
+#else
+#define _POSIX_SOURCE   1
+#define _POSIX_C_SOURCE 199506L
+#define _XOPEN_SOURCE   500
+// FreeBSD takes a different approach to _ISOC99_SOURCE: on FreeBSD it
+// means "I want *just* C99 things", whereas on GNU libc and Solaris
+// it means "I also want C99 things".
+//
+// On both GNU libc and FreeBSD, _ISOC99_SOURCE is implied by
+// _XOPEN_SOURCE==600, but on Solaris it is an error to omit it.
+#define _ISOC99_SOURCE
+// Defining __USE_MINGW_ANSI_STDIO is the most portable way to tell
+// mingw that we want to use the standard %lld style format specifiers,
+// rather than the Windows %I64d style
+#define __USE_MINGW_ANSI_STDIO 1
+#endif
+
+#if defined(darwin_HOST_OS)
+/* If we don't define this the including sysctl breaks with things like
+    /usr/include/bsm/audit.h:224:0:
+         error: syntax error before 'u_char'
+*/
+#define _DARWIN_C_SOURCE 1
+#endif
+
+#endif /* POSIXSOURCE_H */

cbits/hschooks.c

@@ -0,0 +1,59 @@
+/*
+These routines customise the error messages
+for various bits of the RTS.  They are linked
+in instead of the defaults.
+*/
+
+#include "PosixSource.h"
+#include "Rts.h"
+
+#include "HsFFI.h"
+
+#include <string.h>
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+void
+initGCStatistics(void)
+{
+  /* Workaround for #8754: if the GC stats aren't enabled because the
+   compiler couldn't use -Bsymbolic to link the default hooks, then
+   initialize them sensibly. See Note [-Bsymbolic and hooks] in
+   Main.hs. */
+  if (RtsFlags.GcFlags.giveStats == NO_GC_STATS) {
+    RtsFlags.GcFlags.giveStats = COLLECT_GC_STATS;
+  }
+}
+
+void
+defaultsHook (void)
+{
+#if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 802
+    // This helps particularly with large compiles, but didn't work
+    // very well with earlier GHCs because it caused large amounts of
+    // fragmentation.  See rts/sm/BlockAlloc.c:allocLargeChunk().
+    RtsFlags.GcFlags.heapSizeSuggestionAuto = rtsTrue;
+#else
+    RtsFlags.GcFlags.heapSizeSuggestion = 6*1024*1024 / BLOCK_SIZE;
+#endif
+
+    RtsFlags.GcFlags.maxStkSize         = 512*1024*1024 / sizeof(W_);
+
+    initGCStatistics();
+
+    // See #3408: the default idle GC time of 0.3s is too short on
+    // Windows where we receive console events once per second or so.
+#if __GLASGOW_HASKELL__ >= 703
+    RtsFlags.GcFlags.idleGCDelayTime = SecondsToTime(5);
+#else
+    RtsFlags.GcFlags.idleGCDelayTime = 5*1000;
+#endif
+}
+
+void
+StackOverflowHook (StgWord stack_size)    /* in bytes */
+{
+    fprintf(stderr, "GHC stack-space overflow: current limit is %zu bytes.\nUse the `-K<size>' option to increase it.\n", (size_t)stack_size);
+}

package.yaml

@@ -24,22 +24,55 @@ ghc-options:
   - -fno-warn-name-shadowing
 
 dependencies:
+- array >= 0.5
 - base >= 4.7 && < 5
-- pipes >= 4 && < 5
+- bytestring >= 0.10
+- containers >= 0.6
+- deepseq >= 1.4
+- directory >= 1.3
+- filepath >= 1.4
+- ghc >= 8.6.5 && < 9
+- ghc-boot >= 8.6.5 && < 9
+- ghc-prim >= 0.5
+- ghci >= 8.6.5 && < 9
+- haskeline >= 0.7
 - mmorph >= 1 && < 2
+- mtl >= 2 && < 3
+- pipes >= 4 && < 5
+- pretty >= 1.1 && < 1.2
+- prettyprinter >= 1 && < 2
+- process >= 1.6
+- refinery
 - semigroupoids >= 5 && < 6
 - template-haskell >= 2 && < 3
-- megaparsec >= 6 && < 7
-- containers >= 0.5 && < 0.6
 - text >= 1 && < 2
-- prettyprinter >= 1 && < 2
-- pretty >= 1.1 && < 1.2
-- mtl >= 2 && < 3
-- ghc >= 8.4.3 && < 9
+- th-abstraction >= 0.2
+- time >= 1.8
+- transformers >= 0.5
+- unix >= 2.7
 
 library:
   source-dirs: src
 
+executables:
+  tactic-haskell:
+    main: app/Main.hs
+    cpp-options:
+      -DGHCI
+    cc-options:
+      -fPIC
+    c-sources:
+      cbits/hschooks.c
+    include-dirs:
+      cbits/
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+      - tactic-haskell
+
+
 tests:
   tactic-haskell-test:
     main:                Spec.hs

src/GHCi/InteractiveTactic.hs

@@ -0,0 +1,91 @@
+
+-- |
+-- Module      :  GHCi.InteractiveTactic
+-- Copyright   :  (c) Reed Mullanix 2019
+-- License     :  BSD-style
+-- Maintainer  :  [email protected]
+--
+{-# LANGUAGE PartialTypeSignatures #-}
+module GHCi.InteractiveTactic
+( hscTactic
+) where
+
+import Data.Data
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.IO.Class
+
+import Bag
+import DynFlags
+import Lexer
+import FastString
+import Outputable
+import ErrUtils
+import IOEnv
+import HscMain
+import HsDumpAst
+import HscTypes
+import GHC
+import Parser
+import TcRnDriver
+import TcHsType
+import RnUtils
+import StringBuffer
+import SrcLoc
+
+import Language.Haskell.Tactic.Patterns
+import Language.Haskell.Tactic
+-- --------------------------------------------------------------------
+-- Error handling, stolen from internals of HscMain
+throwErrors :: ErrorMessages -> Hsc a
+throwErrors = liftIO . throwIO . mkSrcErr
+
+handleWarnings :: Hsc ()
+handleWarnings = do
+    dflags <- getDynFlags
+    w <- getWarnings
+    liftIO $ printOrThrowWarnings dflags w
+    clearWarnings
+
+getWarnings :: Hsc WarningMessages
+getWarnings = Hsc $ \_ w -> return (w, w)
+
+clearWarnings :: Hsc ()
+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
+
+logWarnings :: WarningMessages -> Hsc ()
+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+
+logWarningsReportErrors :: Messages -> Hsc ()
+logWarningsReportErrors (warns,errs) = do
+    logWarnings warns
+    when (not $ isEmptyBag errs) $ throwErrors errs
+
+
+-- --------------------------------------------------------------------
+hscParseType :: String -> Hsc (LHsType GhcPs)
+hscParseType str = do
+  dflags <- getDynFlags
+  let buf = stringToStringBuffer str
+      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+  case unP parseType (mkPState dflags buf loc) of
+    PFailed warnFn span err -> do
+      logWarningsReportErrors (warnFn dflags)
+      handleWarnings
+      let msg = mkPlainErrMsg dflags span err
+      throwErrors $ unitBag msg
+    POk pst ty -> do
+      logWarningsReportErrors (getMessages pst dflags)
+      liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parsed" (ppr ty)
+      liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser AST" $ showAstData NoBlankSrcSpan ty
+      return $ ty
+
+hscTactic :: HscEnv -> Tactic () -> String -> IO (Maybe Expr)
+hscTactic hsc_env0 tac str = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  psTy <- hscParseType str
+  (ty, _kind) <- ioMsgMaybe $ tcRnType hsc_env True psTy
+  (msgs, ext) <- ioMsgMaybe $ runTcInteractive hsc_env $ runTactic ty tac
+  logWarningsReportErrors msgs
+  return ext