Merge branch 'master' into find-cache-master

Language/Haskell/GhcMod/DynFlags.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TemplateHaskell #-}
 
 module Language.Haskell.GhcMod.DynFlags where
 
@@ -10,6 +10,7 @@ import GHC.Paths (libdir)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.DebugLogger
+import Language.Haskell.GhcMod.DynFlagsTH
 import System.IO.Unsafe (unsafePerformIO)
 import Prelude
 
@@ -102,7 +103,14 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
 setNoMaxRelevantBindings = id
 #endif
 
-deferErrors :: DynFlags -> Ghc DynFlags
+deferErrors :: Monad m => DynFlags -> m DynFlags
 deferErrors df = return $
   Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
   Gap.setDeferTypeErrors $ setNoWarningFlags df
+
+----------------------------------------------------------------
+
+deriveEqDynFlags [d|
+  eqDynFlags :: DynFlags -> DynFlags -> Bool
+  eqDynFlags = undefined
+ |]

Language/Haskell/GhcMod/DynFlagsTH.hs

@@ -0,0 +1,121 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE CPP, TemplateHaskell #-}
+module Language.Haskell.GhcMod.DynFlagsTH where
+
+import Language.Haskell.TH.Syntax
+import Control.Applicative
+import Data.Maybe
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import DynFlags
+import Prelude
+
+deriveEqDynFlags :: Q [Dec] -> Q [Dec]
+deriveEqDynFlags qds = do
+  ~(TyConI (DataD [] _ [] [ctor] _ )) <- reify ''DynFlags
+  let ~(RecC _ fs) = ctor
+
+  a <- newName "a"
+  b <- newName "b"
+
+  e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs)
+
+  tysig@(SigD n _) :_ <- qds
+
+  return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]]
+
+ where
+   eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)
+   eq a b (fn@(Name (OccName fon) _), _, ft)
+       | not (isUneqable || isIgnored) = Just expr
+       | otherwise = Nothing
+    where
+       isUneqable = everything (||) (mkQ False hasUnEqable) ft
+
+       hasUnEqable ArrowT = True
+       hasUnEqable (ConT (Name (OccName on) _))
+           | any (==on) ignoredTypeNames = True
+           | any (==on) ignoredTypeOccNames = True
+       hasUnEqable _ = False
+
+       isIgnored = fon `elem` ignoredNames
+
+       ignoredNames = [ "pkgDatabase" -- 7.8
+#if __GLASGOW_HASKELL__ <= 706
+                      , "ways" -- 'Ways' is not exported :/
+#endif
+                      ]
+       ignoredTypeNames =
+           [ "LogAction"
+           , "PackageState"
+           , "Hooks"
+           , "FlushOut"
+           , "FlushErr"
+           , "Settings" -- I think these can't cange at runtime
+           ]
+       ignoredTypeOccNames = [ "OnOff" ]
+
+       fa = AppE (VarE fn) (VarE a)
+       fb = AppE (VarE fn) (VarE b)
+       expr =
+         case fon of
+           "rtsOptsEnabled" -> do
+               eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True
+                              eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True
+                              eqfn RtsOptsAll RtsOptsAll = True
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+
+#if __GLASGOW_HASKELL__ >= 710
+           "sigOf" -> do
+               eqfn <- [| let eqfn NotSigOf NotSigOf = True
+                              eqfn (SigOf a') (SigOf b') = a' == b'
+                              eqfn (SigOfMap a') (SigOfMap b') = a' == b'
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+#endif
+
+#if __GLASGOW_HASKELL <= 706
+           "profAuto" -> do
+               eqfn <- [| let eqfn NoProfAuto NoProfAuto = True
+                              eqfn ProfAutoAll ProfAutoAll = True
+                              eqfn ProfAutoTop ProfAutoTop = True
+                              eqfn ProfAutoExports ProfAutoExports = True
+                              eqfn ProfAutoCalls ProfAutoCalls = True
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+#endif
+
+#if __GLASGOW_HASKELL__ >= 706
+           "language" -> do
+               eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True
+                              eqfn (Just Haskell2010) (Just Haskell2010) = True
+                              eqfn _ _ = False
+                          in eqfn
+                       |]
+               return $ AppE (AppE eqfn fa) fb
+#endif
+
+           _ ->
+               return $ InfixE (Just fa) (VarE '(==)) (Just fb)

Language/Haskell/GhcMod/FileMapping.hs

@@ -46,8 +46,10 @@ loadMappedFileSource :: IOish m
                      -> GhcModT m ()
 loadMappedFileSource from src = do
   tmpdir <- cradleTempDir `fmap` cradle
+  enc <- liftIO . mkTextEncoding . optEncoding =<< options
   to <- liftIO $ do
     (fn, h) <- openTempFile tmpdir (takeFileName from)
+    hSetEncoding h enc
     hPutStr h src
     hClose h
     return fn

Language/Haskell/GhcMod/LightGhc.hs

@@ -42,3 +42,7 @@ runLightGhc :: HscEnv -> LightGhc a -> IO a
 runLightGhc env action = do
   renv <- newIORef env
   flip runReaderT renv $ unLightGhc action
+
+runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a
+runLightGhc' renv action = do
+  flip runReaderT renv $ unLightGhc action

Language/Haskell/GhcMod/Logger.hs

@@ -169,6 +169,6 @@ checkErrorPrefix :: String
 checkErrorPrefix = "Dummy:0:0:Error:"
 
 warningAsErrorPrefixes :: [String]
-warningAsErrorPrefixes = ["Couldn't match expected type"
+warningAsErrorPrefixes = [ "Couldn't match expected type"
                          , "Couldn't match type"
                          , "No instance for"]

Language/Haskell/GhcMod/Options/DocUtils.hs

@@ -0,0 +1,48 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+module Language.Haskell.GhcMod.Options.DocUtils (
+  ($$),
+  ($$$),
+  (<=>),
+  (<$$>),
+  (<||>)
+) where
+
+import Options.Applicative
+import Data.Monoid
+import Prelude
+
+infixl 6 <||>
+infixr 7 <$$>
+infixr 7 $$
+infixr 8 <=>
+infixr 9 $$$
+
+($$) :: (a -> b) -> a -> b
+($$) = ($)
+
+($$$) :: (a -> b) -> a -> b
+($$$) = ($)
+
+(<||>) :: Alternative a => a b -> a b -> a b
+(<||>) = (<|>)
+
+(<=>) :: Monoid m => m -> m -> m
+(<=>) = (<>)
+
+(<$$>) :: Functor f => (a -> b) -> f a -> f b
+(<$$>) = (<$>)

Language/Haskell/GhcMod/Options/Help.hs

@@ -0,0 +1,79 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
+
+module Language.Haskell.GhcMod.Options.Help where
+
+import Options.Applicative
+import Options.Applicative.Help.Pretty (Doc)
+import qualified Options.Applicative.Help.Pretty as PP
+import Control.Monad.State
+import GHC.Exts( IsString(..) )
+import Data.Maybe
+import Data.Monoid
+import Prelude
+
+newtype MyDocM s a = MyDoc {unwrapState :: State s a}
+  deriving (Monad, Functor, Applicative, MonadState s)
+type MyDoc = MyDocM (Maybe Doc) ()
+
+instance IsString (MyDocM (Maybe Doc) a) where
+    fromString = append . para
+
+instance Monoid (MyDocM (Maybe Doc) ()) where
+  mappend a b = append $ doc a <> doc b
+  mempty = append PP.empty
+
+para :: String -> Doc
+para = PP.fillSep . map PP.text . words
+
+append :: Doc -> MyDocM (Maybe Doc) a
+append s = modify m >> return undefined
+  where
+    m :: Maybe Doc -> Maybe Doc
+    m Nothing = Just s
+    m (Just old) = Just $ old PP..$. s
+
+infixr 7 \\
+(\\) :: MyDoc -> MyDoc -> MyDoc
+(\\) a b = append $ doc a PP.<+> doc b
+
+doc :: MyDoc -> Doc
+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState
+
+help' :: MyDoc -> Mod f a
+help' = helpDoc . Just . doc
+
+desc :: MyDoc -> InfoMod a
+desc = footerDoc . Just . doc . indent 2
+
+code :: MyDoc -> MyDoc
+code x = do
+  _ <- " "
+  indent 4 x
+  " "
+
+progDesc' :: MyDoc -> InfoMod a
+progDesc' = progDescDoc . Just . doc
+
+indent :: Int -> MyDoc -> MyDoc
+indent n = append . PP.indent n . doc
+
+int' :: Int -> MyDoc
+int' = append . PP.int
+
+para' :: String -> MyDoc
+para' = append . para

Language/Haskell/GhcMod/Options/Options.hs

@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module Language.Haskell.GhcMod.Options.Options (
+    globalArgSpec
+  , parseCmdLineOptions
+) where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Types
+import Control.Arrow
+import Data.Char (toUpper, toLower)
+import Data.List (intercalate)
+import Language.Haskell.GhcMod.Read
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
+import Data.Monoid
+import Prelude
+
+-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing
+-- @Options@ set accordingly.
+parseCmdLineOptions :: [String] -> Maybe Options
+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+    logLevelSwitch <*>
+           logLevelOption
+      <||> silentSwitch
+  where
+    logLevelOption =
+      option parseLL
+        $$  long "verbose"
+        <=> metavar "LEVEL"
+        <=> value GmWarning
+        <=> showDefaultWith showLL
+        <=> help' $$$ do
+          "Set log level ("
+            <> int' (fromEnum (minBound :: GmLogLevel))
+            <> "-"
+            <> int' (fromEnum (maxBound :: GmLogLevel))
+            <> ")"
+          "You can also use strings (case-insensitive):"
+          para'
+            $ intercalate ", "
+            $ map showLL ([minBound..maxBound] :: [GmLogLevel])
+    logLevelSwitch =
+      repeatAp succ' . length <$> many $$ flag' ()
+        $$  short 'v'
+        <=> help "Increase log level"
+    silentSwitch = flag' GmSilent
+        $$  long "silent"
+        <=> short 's'
+        <=> help "Be silent, set log level to 'silent'"
+    showLL = drop 2 . map toLower . show
+    repeatAp f n = foldr (.) id (replicate n f)
+    succ' x | x == maxBound = x
+            | otherwise     = succ x
+    parseLL = do
+      v <- readerAsk
+      let
+        il'= toEnum . min maxBound <$> readMaybe v
+        ll' = readMaybe ("Gm" ++ capFirst v)
+      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
+    capFirst (h:t) = toUpper h : map toLower t
+    capFirst [] = []
+
+outputOptsSpec :: Parser OutputOpts
+outputOptsSpec = OutputOpts
+      <$> logLevelParser
+      <*> flag PlainStyle LispStyle
+          $$  long "tolisp"
+          <=> short 'l'
+          <=> help "Format output as an S-Expression"
+      <*> LineSeparator <$$> strOption
+          $$  long "boundary"
+          <=> long "line-separator"
+          <=> short 'b'
+          <=> metavar "SEP"
+          <=> value "\0"
+          <=> showDefault
+          <=> help "Output line separator"
+      <*> optional $$ splitOn ',' <$$> strOption
+          $$  long "line-prefix"
+          <=> metavar "OUT,ERR"
+          <=> help "Output prefixes"
+
+programsArgSpec :: Parser Programs
+programsArgSpec = Programs
+      <$> strOption
+          $$  long "with-ghc"
+          <=> value "ghc"
+          <=> showDefault
+          <=> help "GHC executable to use"
+      <*> strOption
+          $$  long "with-ghc-pkg"
+          <=> value "ghc-pkg"
+          <=> showDefault
+          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
+      <*> strOption
+          $$  long "with-cabal"
+          <=> value "cabal"
+          <=> showDefault
+          <=> help "cabal-install executable to use"
+      <*> strOption
+          $$  long "with-stack"
+          <=> value "stack"
+          <=> showDefault
+          <=> help "stack executable to use"
+
+-- | An optparse-applicative @Parser@ sepcification for @Options@ so that
+-- applications making use of the ghc-mod API can have a consistent way of
+-- parsing global options.
+globalArgSpec :: Parser Options
+globalArgSpec = Options
+      <$> outputOptsSpec
+      <*> programsArgSpec
+      <*> many $$ strOption
+          $$  long "ghcOpt"
+          <=> long "ghc-option"
+          <=> short 'g'
+          <=> metavar "OPT"
+          <=> help "Option to be passed to GHC"
+      <*> many fileMappingSpec
+      <*> strOption
+          $$  long "encoding"
+          <=> value "UTF-8"
+          <=> showDefault
+          <=> help "I/O encoding"
+  where
+    fileMappingSpec =
+      getFileMapping . splitOn '=' <$> strOption
+        $$  long "map-file"
+        <=> metavar "MAPPING"
+        <=> fileMappingHelp
+    fileMappingHelp = help' $ do
+        "Redirect one file to another"
+        "--map-file \"file1.hs=file2.hs\""
+        indent 4 $ do
+          "can be used to tell ghc-mod"
+            \\ "that it should take source code"
+            \\ "for `file1.hs` from `file2.hs`."
+          "`file1.hs` can be either full path,"
+            \\ "or path relative to project root."
+          "`file2.hs` has to be either relative to project root,"
+            \\  "or full path (preferred)"
+        "--map-file \"file.hs\""
+        indent 4 $ do
+          "can be used to tell ghc-mod that it should take"
+            \\ "source code for `file.hs` from stdin. File end"
+            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
+            \\ "`file.hs` may or may not exist, and should be"
+            \\ "either full path, or relative to project root."
+    getFileMapping = second (\i -> if null i then Nothing else Just i)

Language/Haskell/GhcMod/Target.hs

@@ -66,29 +66,41 @@ runGmPkgGhc action = do
     withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
 
 initSession :: IOish m
-            => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()
+            => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m ()
 initSession opts mdf = do
    s <- gmsGet
    case gmGhcSession s of
-     Just GmGhcSession {..} | gmgsOptions /= opts-> do
-         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
-         putNewSession s
-     Just _ -> return ()
      Nothing -> do
          gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
          putNewSession s
+     Just GmGhcSession {..} -> do
+         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
+         crdl <- cradle
+         changed <- liftIO $ runLightGhc' gmgsSession $ do
+           df <- getSessionDynFlags
+           ndf <- initDF crdl
+           return $ ndf `eqDynFlags` df
 
+         if changed
+            then putNewSession s
+            else return ()
  where
-   putNewSession s = do
-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)
-     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
-
-   newSession Cradle { cradleTempDir } = liftIO $ do
-     runGhc (Just libdir) $ do
+   initDF Cradle { cradleTempDir } = do
        let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
        _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
+       getSessionDynFlags
+
+   putNewSession s = do
+     rghc <- (liftIO . newIORef =<< newSession)
+     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
+
+   newSession = do
+     crdl <- cradle
+     liftIO $ runGhc (Just libdir) $ do
+       _ <- initDF crdl
        getSession
 
+
 -- | Drop the currently active GHC session, the next that requires a GHC session
 -- will initialize a new one.
 dropSession :: IOish m => GhcModT m ()
@@ -114,7 +126,7 @@ runGmlT fns action = runGmlT' fns return action
 -- of certain files or modules, with updated GHC flags
 runGmlT' :: IOish m
               => [Either FilePath ModuleName]
-              -> (DynFlags -> Ghc DynFlags)
+              -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
               -> GmlT m a
               -> GhcModT m a
 runGmlT' fns mdf action = runGmlTWith fns mdf id action
@@ -124,7 +136,7 @@ runGmlT' fns mdf action = runGmlTWith fns mdf id action
 -- transformation
 runGmlTWith :: IOish m
                  => [Either FilePath ModuleName]
-                 -> (DynFlags -> Ghc DynFlags)
+                 -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
                  -> (GmlT m a -> GmlT m b)
                  -> GmlT m a
                  -> GhcModT m b

Language/Haskell/GhcMod/Types.hs

@@ -105,6 +105,7 @@ data Options = Options {
     -- | GHC command line options set on the @ghc-mod@ command line
   , optGhcUserOptions :: [GHCOption]
   , optFileMappings   :: [(FilePath, Maybe FilePath)]
+  , optEncoding       :: String
   } deriving (Show)
 
 -- | A default 'Options'.
@@ -124,6 +125,7 @@ defaultOptions = Options {
     }
   , optGhcUserOptions = []
   , optFileMappings   = []
+  , optEncoding       = "UTF-8"
   }
 
 ----------------------------------------------------------------
@@ -132,7 +134,7 @@ data Project = CabalProject
              | SandboxProject
              | PlainProject
              | StackProject StackEnv
-               deriving (Eq, Show)
+               deriving (Eq, Show, Ord)
 
 isCabalHelperProject :: Project -> Bool
 isCabalHelperProject StackProject {} = True
@@ -144,7 +146,7 @@ data StackEnv = StackEnv {
     , seBinPath       :: [FilePath]
     , seSnapshotPkgDb :: FilePath
     , seLocalPkgDb    :: FilePath
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Ord)
 
 -- | The environment where this library is used.
 data Cradle = Cradle {
@@ -159,7 +161,7 @@ data Cradle = Cradle {
   , cradleCabalFile  :: Maybe FilePath
   -- | The build info directory.
   , cradleDistDir    :: FilePath
-  } deriving (Eq, Show)
+  } deriving (Eq, Show, Ord)
 
 data GmStream = GmOutStream | GmErrStream
                 deriving (Show)