-- | Type-check using GHC.

module Fay.Compiler.Typecheck where

import           Fay.Compiler.Prelude

import           Fay.Compiler.Defaults
import           Fay.Compiler.Misc
import           Fay.Config
import           Fay.Types

import qualified GHC.Paths             as GHCPaths

import           System.Directory
import           System.Environment

-- | Call out to GHC to type-check the file.
typecheck :: Config -> FilePath -> IO (Either CompileError String)
typecheck :: Config -> FilePath -> IO (Either CompileError FilePath)
typecheck Config
cfg FilePath
fp = do
  FilePath
faydir <- IO FilePath
faySourceDir
  let includes :: [(Maybe FilePath, FilePath)]
includes = Config -> [(Maybe FilePath, FilePath)]
configDirectoryIncludes Config
cfg

  -- Remove the fay source dir from includeDirs to prevent errors on FFI instance declarations.
  let includeDirs :: [FilePath]
includeDirs = ((Maybe FilePath, FilePath) -> FilePath)
-> [(Maybe FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd ([(Maybe FilePath, FilePath)] -> [FilePath])
-> ([(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)])
-> [(Maybe FilePath, FilePath)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath, FilePath) -> Bool)
-> [(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
faydir) (FilePath -> Bool)
-> ((Maybe FilePath, FilePath) -> FilePath)
-> (Maybe FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FilePath, FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)])
-> ([(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)])
-> [(Maybe FilePath, FilePath)]
-> [(Maybe FilePath, FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath, FilePath) -> Bool)
-> [(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe FilePath -> Bool)
-> ((Maybe FilePath, FilePath) -> Maybe FilePath)
-> (Maybe FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FilePath, FilePath) -> Maybe FilePath
forall a b. (a, b) -> a
fst) ([(Maybe FilePath, FilePath)] -> [FilePath])
-> [(Maybe FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [(Maybe FilePath, FilePath)]
includes
  let packages :: [FilePath]
packages = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath])
-> ([(Maybe FilePath, FilePath)] -> [FilePath])
-> [(Maybe FilePath, FilePath)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath, FilePath) -> FilePath)
-> [(Maybe FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FilePath -> FilePath)
-> ((Maybe FilePath, FilePath) -> Maybe FilePath)
-> (Maybe FilePath, FilePath)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FilePath, FilePath) -> Maybe FilePath
forall a b. (a, b) -> a
fst) ([(Maybe FilePath, FilePath)] -> [FilePath])
-> ([(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)])
-> [(Maybe FilePath, FilePath)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath, FilePath) -> Bool)
-> [(Maybe FilePath, FilePath)] -> [(Maybe FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool)
-> ((Maybe FilePath, FilePath) -> Maybe FilePath)
-> (Maybe FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FilePath, FilePath) -> Maybe FilePath
forall a b. (a, b) -> a
fst) ([(Maybe FilePath, FilePath)] -> [FilePath])
-> [(Maybe FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [(Maybe FilePath, FilePath)]
includes

  [FilePath]
ghcPackageDbArgs <-
    case Config -> Maybe FilePath
configPackageConf Config
cfg of
      Maybe FilePath
Nothing -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      Just FilePath
pk -> do
        FilePath
flag <- IO FilePath
getGhcPackageDbFlag
        [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
flag FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
'=' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
pk]
  let flags :: [FilePath]
flags =
          [ FilePath
"-fno-code"
          , FilePath
"-hide-all-packages"
          , FilePath
"-cpp", FilePath
"-pgmPcpphs", FilePath
"-optP--cpp"
          , FilePath
"-optP-C" -- Don't let hse-cpp remove //-style comments.
          , FilePath
"-DFAY=1"
          , FilePath
"-main-is"
          , FilePath
"Language.Fay.DummyMain"
          , FilePath
"-i" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
":" [FilePath]
includeDirs
          , FilePath
fp ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
ghcPackageDbArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
wallF [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"-package " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) [FilePath]
packages
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
GHCPaths.ghc
  Bool
stackInNixShell <- (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"STACK_IN_NIX_SHELL")
  let ghcPath :: FilePath
ghcPath = if Bool
exists
        then if (FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf FilePath
".stack" FilePath
GHCPaths.ghc Bool -> Bool -> Bool
|| Bool
stackInNixShell)
             then FilePath
"stack"
             else FilePath
GHCPaths.ghc
        else FilePath
"ghc"
      extraFlags :: [FilePath]
extraFlags = case FilePath
ghcPath of
        FilePath
"stack" -> [FilePath
"exec",FilePath
"--",FilePath
"ghc"]
        FilePath
_       -> []
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configShowGhcCalls Config
cfg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO ()
putStrLn (FilePath -> IO ())
-> ([FilePath] -> FilePath) -> [FilePath] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
ghcPath FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: ([FilePath]
extraFlags [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
flags)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stackInNixShell (FilePath -> IO ()
unsetEnv FilePath
"STACK_IN_NIX_SHELL")
  Either (FilePath, FilePath) (FilePath, FilePath)
res <- FilePath
-> [FilePath]
-> FilePath
-> IO (Either (FilePath, FilePath) (FilePath, FilePath))
readAllFromProcess FilePath
ghcPath ([FilePath]
extraFlags [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
flags) FilePath
""
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stackInNixShell (FilePath -> FilePath -> IO ()
setEnv FilePath
"STACK_IN_NIX_SHELL" FilePath
"1")
  ((FilePath, FilePath) -> IO (Either CompileError FilePath))
-> ((FilePath, FilePath) -> IO (Either CompileError FilePath))
-> Either (FilePath, FilePath) (FilePath, FilePath)
-> IO (Either CompileError FilePath)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either CompileError FilePath -> IO (Either CompileError FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CompileError FilePath -> IO (Either CompileError FilePath))
-> ((FilePath, FilePath) -> Either CompileError FilePath)
-> (FilePath, FilePath)
-> IO (Either CompileError FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileError -> Either CompileError FilePath
forall a b. a -> Either a b
Left (CompileError -> Either CompileError FilePath)
-> ((FilePath, FilePath) -> CompileError)
-> (FilePath, FilePath)
-> Either CompileError FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CompileError
GHCError (FilePath -> CompileError)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> CompileError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) (Either CompileError FilePath -> IO (Either CompileError FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CompileError FilePath -> IO (Either CompileError FilePath))
-> ((FilePath, FilePath) -> Either CompileError FilePath)
-> (FilePath, FilePath)
-> IO (Either CompileError FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Either CompileError FilePath
forall a b. b -> Either a b
Right (FilePath -> Either CompileError FilePath)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Either CompileError FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) Either (FilePath, FilePath) (FilePath, FilePath)
res
   where
    wallF :: [FilePath]
wallF | Config -> Bool
configWall Config
cfg = [FilePath
"-Wall"]
          | Bool
otherwise = []