瀏覽代碼

Starting to switch to Cabal format

Getty Ritter 6 年之前
父節點
當前提交
cf54b9a83b
共有 5 個文件被更改,包括 69 次插入9 次删除
  1. 7 2
      hatch.cabal
  2. 27 3
      src/Config.hs
  3. 9 2
      src/Hatch.hs
  4. 9 2
      src/Types.hs
  5. 17 0
      src/Util.hs

+ 7 - 2
hatch.cabal

@@ -1,14 +1,16 @@
 name: hatch
 name: hatch
-version: 0.1.0.0
+version: 0.1
 synopsis: A Haskell toolchain manager
 synopsis: A Haskell toolchain manager
+description:
+  The @hatch@ program allows for project-, user-, and system-level
+  switching between versions of GHC
 license: BSD3
 license: BSD3
 author: Getty Ritter <hatch@infinitenegativeutility.com>
 author: Getty Ritter <hatch@infinitenegativeutility.com>
 maintainer: Getty Ritter <hatch@infinitenegativeutility.com>
 maintainer: Getty Ritter <hatch@infinitenegativeutility.com>
 copyright: @2018 Getty Ritter
 copyright: @2018 Getty Ritter
 category: Build
 category: Build
 build-type: Simple
 build-type: Simple
-cabal-version: >=1.14
+cabal-version: >=2.0
 
 
 library
 library
   hs-source-dirs: src
   hs-source-dirs: src
@@ -22,11 +24,13 @@ library
                , directory
                , directory
                , filepath
                , filepath
                , unix
                , unix
+               , Cabal
   default-language: Haskell2010
   default-language: Haskell2010
   default-extensions: ScopedTypeVariables
   default-extensions: ScopedTypeVariables
   exposed-modules: Hatch
   exposed-modules: Hatch
   other-modules: Types
   other-modules: Types
                  Config
                  Config
+                 Util
 
 
 executable hatch
 executable hatch
   hs-source-dirs: hatch
   hs-source-dirs: hatch

+ 27 - 3
src/Config.hs

@@ -3,7 +3,8 @@
 
 
 module Config
 module Config
 ( ConfigFile
 ( ConfigFile
-, fetchConfig
+, readConfig
+, readProjectConfig
 , Ini.iniValueL
 , Ini.iniValueL
 ) where
 ) where
 
 
@@ -13,22 +14,27 @@ import qualified Data.Ini.Config.Bidir as Ini
 import qualified Data.Text as T
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import qualified Data.Text.IO as T
 import           Data.Monoid ((<>))
 import           Data.Monoid ((<>))
+import qualified Distribution.ParseUtils as Cabal
 import qualified System.Directory as Sys
 import qualified System.Directory as Sys
 import           System.FilePath ((</>))
 import           System.FilePath ((</>))
+import qualified System.FilePath as Sys
 import qualified System.Exit as Sys
 import qualified System.Exit as Sys
 import qualified System.Environment.XDG.BaseDir as Sys
 import qualified System.Environment.XDG.BaseDir as Sys
 import           Text.Read (readMaybe)
 import           Text.Read (readMaybe)
 
 
 import           Types
 import           Types
+import           Util
 
 
 type ConfigFile = Ini.Ini Config
 type ConfigFile = Ini.Ini Config
 
 
+
 defaultConfig :: IO Config
 defaultConfig :: IO Config
 defaultConfig = do
 defaultConfig = do
   _configInstallPath <- Sys.getUserDataDir ("hatch" </> "install")
   _configInstallPath <- Sys.getUserDataDir ("hatch" </> "install")
   let _configCurrentCompiler = Nothing
   let _configCurrentCompiler = Nothing
   return Config { .. }
   return Config { .. }
 
 
+
 configSpec :: Ini.IniSpec Config ()
 configSpec :: Ini.IniSpec Config ()
 configSpec = do
 configSpec = do
   Ini.section "hatch" $ do
   Ini.section "hatch" $ do
@@ -36,6 +42,7 @@ configSpec = do
                            & Ini.optional
                            & Ini.optional
     configCurrentCompiler .=? Ini.field "current" versionField
     configCurrentCompiler .=? Ini.field "current" versionField
 
 
+
 versionField :: Ini.FieldValue Compiler
 versionField :: Ini.FieldValue Compiler
 versionField = Ini.FieldValue { .. }
 versionField = Ini.FieldValue { .. }
   where
   where
@@ -49,6 +56,7 @@ versionField = Ini.FieldValue { .. }
       | otherwise = Left ("Bad GHC version: " ++ show t)
       | otherwise = Left ("Bad GHC version: " ++ show t)
     fvEmit = T.pack . compilerString
     fvEmit = T.pack . compilerString
 
 
+
 locateConfig :: FilePath -> IO (Maybe FilePath)
 locateConfig :: FilePath -> IO (Maybe FilePath)
 locateConfig filename = do
 locateConfig filename = do
   xdgLocs <- Sys.getAllConfigFiles "hatch" filename
   xdgLocs <- Sys.getAllConfigFiles "hatch" filename
@@ -60,8 +68,23 @@ locateConfig filename = do
     []          -> return Nothing
     []          -> return Nothing
     ((fp, _):_) -> return (Just fp)
     ((fp, _):_) -> return (Just fp)
 
 
-fetchConfig :: IO (Ini.Ini Config)
-fetchConfig = do
+
+readProjectConfig :: IO ([Cabal.Field])
+readProjectConfig = Sys.getCurrentDirectory >>= go
+  where go "/" = return []
+        go path = do
+          exists <- Sys.doesFileExist (path </> ".hatch")
+          if exists
+            then do
+              content <- readFile (path </> ".hatch")
+              case Cabal.readFields content of
+                Cabal.ParseOk _ rs -> return rs
+                _ -> return []
+            else go (Sys.takeDirectory path)
+
+
+readConfig :: IO (Ini.Ini Config)
+readConfig = do
   def <- defaultConfig
   def <- defaultConfig
   let ini = Ini.ini def configSpec
   let ini = Ini.ini def configSpec
   confLocation <- locateConfig "config.ini"
   confLocation <- locateConfig "config.ini"
@@ -72,5 +95,6 @@ fetchConfig = do
       content <- T.readFile fp
       content <- T.readFile fp
       case Ini.parseIni content ini of
       case Ini.parseIni content ini of
         Left err -> do
         Left err -> do
+          printErr err
           Sys.die err
           Sys.die err
         Right x -> return x
         Right x -> return x

+ 9 - 2
src/Hatch.hs

@@ -2,7 +2,7 @@ module Hatch
 ( main
 ( main
 ) where
 ) where
 
 
-import           Lens.Family
+import           Lens.Family ((^.))
 import qualified System.Environment as Sys
 import qualified System.Environment as Sys
 import           System.FilePath ((</>))
 import           System.FilePath ((</>))
 import qualified System.FilePath as Sys
 import qualified System.FilePath as Sys
@@ -11,10 +11,11 @@ import qualified System.Posix.Process as Sys
 
 
 import Config
 import Config
 import Types
 import Types
+import Util
 
 
 main :: IO ()
 main :: IO ()
 main = do
 main = do
-  conf <- fetchConfig
+  conf <- readConfig
   print (conf^.iniValueL)
   print (conf^.iniValueL)
   programName <- Sys.takeFileName `fmap` Sys.getProgName
   programName <- Sys.takeFileName `fmap` Sys.getProgName
   if programName == "hatch"
   if programName == "hatch"
@@ -36,6 +37,12 @@ runAsProxy conf program = do
       Sys.executeFile progn False args Nothing
       Sys.executeFile progn False args Nothing
 
 
 
 
+data HatchCommand
+  = SwitchCompiler
+  | FetchCompiler
+    deriving (Eq, Show)
+
 runAsHatch :: ConfigFile -> IO ()
 runAsHatch :: ConfigFile -> IO ()
 runAsHatch _ = do
 runAsHatch _ = do
+  printErr "testing"
   putStrLn "Invoking as Hatch!"
   putStrLn "Invoking as Hatch!"

+ 9 - 2
src/Types.hs

@@ -1,8 +1,15 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
 
 
-module Types where
+module Types
+( Compiler(..)
+, compilerVersion
+, Config(..)
+, configInstallPath
+, configCurrentCompiler
+, compilerString
+) where
 
 
-import qualified Data.Text as T
 import qualified Lens.Family.TH as Lens
 import qualified Lens.Family.TH as Lens
 
 
 data Compiler = Compiler
 data Compiler = Compiler

+ 17 - 0
src/Util.hs

@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Util
+( printErr
+) where
+
+import           Control.Monad (when)
+import qualified System.Posix.Terminal as Unix
+import qualified System.Posix.IO as Unix
+
+printErr :: String -> IO ()
+printErr msg = do
+  isTTY <- Unix.queryTerminal Unix.stdOutput
+  when isTTY $ putStr "\x1b[91m"
+  putStr msg
+  when isTTY $ putStr "\x1b[39m"
+  putStrLn ""