change the :set directive to behave like ghci.

What used to be :set is now :option.

Addresses (#108 part 1), if you use :set -XExistentialQuantification

The -package flag is broken for now.

src/IHaskell/Eval/Completion.hs

@@ -46,11 +46,12 @@ import IHaskell.Eval.ParseShell (parseShell)
 data CompletionType
      = Empty
      | Identifier String
-     | Extension String
+     | DynFlag String
      | Qualified String String
      | ModuleName String String
      | HsFilePath String String
      | FilePath   String String 
+     | KernelOption String
      deriving (Show, Eq)
 
 complete :: String -> Int -> Interpreter (String, [String])
@@ -93,16 +94,33 @@ complete line pos = do
                          else intercalate "." [previous, candidate]
             return $ filter (prefix `isPrefixOf`) moduleNames
 
-          Extension ext -> do
+          DynFlag ext -> do
             let extName (name, _, _) = name
-                names = map extName xFlags
-                nonames = map ("No" ++) names
-            return $ filter (ext `isPrefixOf`) $ names ++ nonames
+                otherNames = ["-package","-Wall","-w"] ++
+                            concatMap getSetName kernelOpts
+                fNames = map ("-f"++) (names ++ nonames)
+                    where
+                    -- possibly leave out the fLangFlags? The
+                    -- -XUndecidableInstances vs. obsolete
+                    -- -fallow-undecidable-instances
+                    names = map extName fFlags ++ 
+                            map extName fWarningFlags ++ 
+                            map extName fLangFlags
+                    nonames = map ("no"++) names
+
+                xNames = map ("-X"++) (names ++ nonames)
+                    where
+                    names = map extName xFlags
+                    nonames = map ("No" ++) names
+            return $ filter (ext `isPrefixOf`) $ fNames ++ xNames ++ otherNames
 
           HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
 
           FilePath   lineUpToCursor match  -> completePath lineUpToCursor
 
+          KernelOption str -> return $
+                    filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
+
   return (matchedText, options)
 
 getTrueModuleName :: String -> Interpreter String
@@ -138,6 +156,10 @@ completionType line loc target
     = case parseShell lineUpToCursor of 
           Right xs -> HsFilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []
           Left  _  -> Empty
+  | startswith ":s" stripped
+    = DynFlag candidate
+  | startswith ":o" stripped
+    = KernelOption candidate
   -- Use target for other completions.
   -- If it's empty, no completion.
   | null target
@@ -146,13 +168,12 @@ completionType line loc target
     = ModuleName dotted candidate
   | isModName && (not . null . init) target
     = Qualified dotted candidate
-  | startswith ":e" stripped
-    = Extension candidate
   | otherwise
     = Identifier candidate
   where stripped = strip line
         dotted = dots target
-        candidate = last target
+        candidate | null target = ""
+                  | otherwise = last target
         dots = intercalate "." . init
         isModName = all isCapitalized (init target)
         isCapitalized = isUpper . head

src/IHaskell/Eval/Evaluate.hs

-{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances  #-}
+{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, PatternGuards  #-}
 
 {- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
                    a statement, declaration, import, or directive.
@@ -43,6 +43,7 @@ import Type
 import Exception (gtry)
 import HscTypes
 import HscMain
+import qualified Linker
 import TcType
 import Unify
 import InstEnv
@@ -71,7 +72,7 @@ import IHaskell.Eval.Util
 import Paths_ihaskell (version)
 import Data.Version (versionBranch)
 
-data ErrorOccurred = Success | Failure deriving Show
+data ErrorOccurred = Success | Failure deriving (Show, Eq, Ord)
 
 debug :: Bool
 debug = False
@@ -317,6 +318,23 @@ wrapExecution state exec = safely state $ exec >>= \res ->
       evalPager = ""
     }
 
+-- | Set dynamic flags.
+--
+-- adapted from GHC's InteractiveUI.hs (newDynFlags)
+setDynFlags :: [String] -> Interpreter [ErrMsg]
+setDynFlags ext = do
+    flags <- getSessionDynFlags
+    (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)
+    let restorePkg x = x { packageFlags = packageFlags flags }
+    -- First, try to check if this flag matches any extension name.
+    new_pkgs <- GHC.setProgramDynFlags (restorePkg flags')
+    GHC.setInteractiveDynFlags (restorePkg flags')
+    return $ map (("Could not parse: " ++) . unLoc) unrecognized ++
+             map ("Warning: " ++)
+                  (map unLoc warnings ++
+                    [ "-package not supported yet"
+                        | packageFlags flags /= packageFlags flags' ])
+
 -- | Return the display data for this command, as well as whether it
 -- resulted in an error.
 evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut
@@ -344,6 +362,7 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
 
   -- Write the module contents to a temporary file in our work directory
   namePieces <- getModuleName contents
+  liftIO (print namePieces)
   let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"
       filename = last namePieces ++ ".hs"
   liftIO $ do
@@ -383,12 +402,51 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
     -- Since nothing prevents loading the module, compile and load it.
     Nothing -> doLoadModule modName modName
 
-evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
-  write $ "Extension: " ++ exts
-  results <- mapM setExtension (words exts)
-  case catMaybes results of
-    [] -> return $ Display []
-    errors -> return $ displayError $ intercalate "\n" errors
+evalCommand a (Directive SetDynFlag flags) state
+    | let f o = case filter (elem o . getSetName) kernelOpts of
+                [] -> Right o
+                [z] | s:_ <- getOptionName z -> Left s
+                    | otherwise -> error ("evalCommand Directive SetDynFlag impossible")
+                ds -> error ("kernelOpts has duplicate:"++ show (map getSetName ds)),
+      (optionFlags,oo) <- partitionEithers $ map f (words flags),
+      not (null optionFlags) = do
+          eo1 <- evalCommand a (Directive SetOption (unwords optionFlags)) state
+          eo2 <- evalCommand a (Directive SetDynFlag (unwords oo)) (evalState eo1)
+          return $ EvalOut {
+                evalStatus = max (evalStatus eo1) (evalStatus eo2),
+                evalResult = evalResult eo1 ++ evalResult eo2,
+                evalState = evalState eo2,
+                evalPager = evalPager eo1 ++ evalPager eo2
+          }
+        
+evalCommand _ (Directive SetDynFlag flags) state = wrapExecution state $ do
+  write $ "DynFlag: " ++ flags
+  errs <- setDynFlags (words flags)
+  return $ case errs of
+      [] -> []
+      _ -> displayError $ intercalate "\n" errs
+
+evalCommand a (Directive SetExtension opts) state = do
+  write $ "Extension: " ++ opts
+  evalCommand a (Directive SetDynFlag (concatMap (" -X"++) (words opts))) state
+
+evalCommand a (Directive SetOption opts) state = do
+  write $ "Option: " ++ opts
+  let (lost, found) = partitionEithers
+        [ case filter (any (w==) . getOptionName) kernelOpts of
+                [x] -> Right (getUpdateKernelState x)
+                [] -> Left w
+                ds -> error ("kernelOpts has duplicate:" ++ show (map getOptionName ds))
+          | w <- words opts ]
+      warn
+        | null lost = []
+        | otherwise = displayError ("Could not recognize options: " ++ intercalate "," lost)
+  return EvalOut {
+    evalStatus = if null lost then Success else Failure,
+    evalResult = warn,
+    evalState = foldl' (flip ($)) state found,
+    evalPager = ""
+  }
 
 evalCommand _ (Directive GetType expr) state = wrapExecution state $ do
   write $ "Type: " ++ expr
@@ -410,49 +468,6 @@ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do
 
   doLoadModule filename modName
 
-
-
--- This is taken largely from GHCi's info section in InteractiveUI.
-evalCommand _ (Directive SetOpt option) state = do
-  write $ "Setting option: " ++ option
-  let opt = strip option
-      newState = setOpt opt state
-      out = case newState of
-        Nothing -> displayError $ "Unknown option: " ++ opt
-        Just _ -> Display []
-
-  return EvalOut {
-    evalStatus = if isJust newState then Success else Failure,
-    evalResult = out,
-    evalState = fromMaybe state newState,
-    evalPager = ""
-  }
-
-  where
-    setOpt :: String -> KernelState -> Maybe KernelState
-
-    setOpt "lint" state = Just $
-      state { getLintStatus = LintOn }
-    setOpt "no-lint" state = Just $
-      state { getLintStatus = LintOff }
-
-    setOpt "svg" state = Just $
-      state { useSvg = True }
-    setOpt "no-svg" state = Just $
-      state { useSvg = False }
-
-    setOpt "show-types" state = Just $
-      state { useShowTypes = True }
-    setOpt "no-show-types" state = Just $
-      state { useShowTypes = False }
-
-    setOpt "show-errors" state = Just $
-      state { useShowErrors = True }
-    setOpt "no-show-errors" state = Just $
-      state { useShowErrors = False }
-
-    setOpt _ _ = Nothing
-
 evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $
   case words cmd of
     "cd":dirs -> do
@@ -548,8 +563,9 @@ evalCommand _ (Directive GetHelp _) state = do
           ,"    :info <name>              -  Print all info for a name."
           ,"    :hoogle <query>           -  Search for a query on Hoogle."
           ,"    :doc <ident>              -  Get documentation for an identifier via Hogole."
-          ,"    :set <opt>                -  Set an option."
-          ,"    :set no-<opt>             -  Unset an option."
+          ,"    :set -XFlag -Wall         -  Set an option (like ghci)."
+          ,"    :option <opt>             -  Set an option."
+          ,"    :option no-<opt>          -  Unset an option."
           ,"    :?, :help                 -  Show this help text."
           ,""
           ,"Any prefix of the commands will also suffice, e.g. use :ty for :type."

src/IHaskell/Eval/Parser.hs

@@ -60,9 +60,10 @@ instance Functor Located where
 data DirectiveType
   = GetType         -- ^ Get the type of an expression via ':type' (or unique prefixes)
   | GetInfo         -- ^ Get info about the identifier via ':info' (or unique prefixes)
-  | SetExtension    -- ^ Enable or disable an extension via ':extension' (or prefixes)
+  | SetDynFlag      -- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set`
   | LoadFile        -- ^ Load a Haskell module.
-  | SetOpt          -- ^ Set various options.
+  | SetOption       -- ^ Set IHaskell kernel option `:option`.
+  | SetExtension    -- ^ `:extension Foo` is a shortcut for `:set -XFoo`
   | ShellCmd        -- ^ Execute a shell command.
   | GetHelp         -- ^ General help via ':?' or ':help'.
   | SearchHoogle    -- ^ Search for something via Hoogle.
@@ -254,9 +255,10 @@ parseDirective (':':directive) line = case find rightDirective directives of
       ,(GetInfo,      "info")
       ,(SearchHoogle, "hoogle")
       ,(GetDoc,       "documentation")
-      ,(SetExtension, "extension")
+      ,(SetDynFlag,   "set")
       ,(LoadFile,     "load")
-      ,(SetOpt,       "set")
+      ,(SetOption,    "option")
+      ,(SetExtension, "extension")
       ,(GetHelp,      "?")
       ,(GetHelp,      "help")
       ]

src/IHaskell/Types.hs

-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, PatternGuards #-}
 {-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
 -- | Description : All message type definitions.
 module IHaskell.Types (
@@ -22,7 +22,9 @@ module IHaskell.Types (
   ViewFormat(..),
   Display(..),
   defaultKernelState,
-  extractPlain
+  extractPlain,
+  kernelOpts,
+  KernelOpt(..),
   ) where
 
 import            ClassyPrelude
@@ -96,6 +98,23 @@ data FrontendType
      | IPythonNotebook
      deriving (Show, Eq, Read)
 
+-- | names the ways to update the IHaskell 'KernelState' by `:set`
+-- ('getSetName') and `:option` ('getOptionName') directives
+data KernelOpt = KernelOpt
+    { getOptionName, getSetName :: [String],
+      getUpdateKernelState :: KernelState -> KernelState }
+
+kernelOpts :: [KernelOpt]
+kernelOpts =
+    [KernelOpt ["lint"]    [] $ \state -> state { getLintStatus = LintOn },
+     KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff },
+     KernelOpt ["svg"]     [] $ \state -> state { useSvg = True },
+     KernelOpt ["no-svg"]  [] $ \state -> state { useSvg = False },
+     KernelOpt ["show-types"]    ["+t"] $ \state -> state { useShowTypes = True },
+     KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False },
+     KernelOpt ["show-errors"]    [] $ \state -> state { useShowErrors = True },
+     KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }]
+
 -- | Initialization information for the kernel.
 data InitInfo = InitInfo {
   extensions :: [String],   -- ^ Extensions to enable at start.