<commit_before>
{-|
Module      : Qux.Commands.Build

Copyright   : (c) <NAME>, 2015
License     : BSD3
Maintainer  : <EMAIL>
-}

{-# OPTIONS_HADDOCK hide, prune #-}

module Qux.Commands.Build where

import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.Reader

import qualified    Data.ByteString as BS
import              Data.List       (intercalate)

import qualified    Language.Qux.Annotated.NameResolver     as NameResolver
import              Language.Qux.Annotated.Parser           hiding (parse)
import qualified    Language.Qux.Annotated.Parser           as P
import              Language.Qux.Annotated.Syntax
import              Language.Qux.Annotated.TypeChecker
import qualified    Language.Qux.Annotated.TypeResolver     as TypeResolver
import qualified    Language.Qux.Llvm.Compiler              as C

import LLVM.General
import LLVM.General.Context hiding (Context)

import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error


data Options = Options {
    optCompile      :: Bool,
    optDestination  :: FilePath,
    optFormat       :: Format,
    optTypeCheck    :: Bool,
    argFilePaths    :: [FilePath]
    }
    deriving (Eq, Show)

defaultOptions :: Options
defaultOptions = Options {
    optCompile      = False,
    optDestination  = "." ++ [pathSeparator],
    optFormat       = Bitcode,
    optTypeCheck    = False,
    argFilePaths    = []
    }

data Format = Assembly | Bitcode
    deriving Eq

instance Show Format where
    show Assembly   = "assembly"
    show Bitcode    = "bitcode"

-- TODO (hjw): simplify all programs as early as possible
-- TODO (hjw): re-use contexts as much as possible

handle :: Options -> IO ()
handle options = do
    let filePaths = argFilePaths options
    fileContents <- mapM readFile filePaths

    ethr <- catchIOError
        (runExceptT $ zipWithM parse filePaths fileContents >>= resolveNames >>= resolveTypes >>= build options)
        (return . Left . ioeGetErrorString)

    case ethr of
        Left error  -> hPutStrLn stderr error >> exitFailure
        Right _     -> return ()

parse :: FilePath -> String -> ExceptT String IO (Program SourcePos)
parse filePath contents = mapExceptT (return . runIdentity) (withExcept show (P.parse program filePath contents))

resolveNames :: [Program SourcePos] -> ExceptT String IO [Program SourcePos]
resolveNames programs = mapM resolve programs
    where
        resolve :: Program SourcePos -> ExceptT String IO (Program SourcePos)
        resolve program = do
            let context'            = NameResolver.context (simp program) (map simp programs)
            let (program', errors)  = NameResolver.runResolve (NameResolver.resolveProgram program) context'

            when (not $ null errors) $ throwError (intercalate "\n\n" $ map show errors)

            return program'

resolveTypes :: [Program SourcePos] -> ExceptT String IO [Program SourcePos]
resolveTypes programs = mapM resolve programs
    where
        baseContext' = baseContext (map simp programs)
        resolve :: Program SourcePos -> ExceptT String IO (Program SourcePos)
        resolve program@(Program _ m _) = return $ TypeResolver.runResolve (TypeResolver.resolveProgram program) (baseContext' { module_ = map simp m })

build :: Options -> [Program SourcePos] -> ExceptT String IO ()
build options programs = do
    let baseContext' = baseContext $ map simp programs

    when (optTypeCheck options) $ mapM_ (\p@(Program _ m _) -> typeCheck (baseContext' { module_ = map simp m }) p) programs
    when (optCompile options)   $ mapM_ (\p@(Program _ m _) -> compile options (baseContext' { module_ = map simp m }) p) programs

typeCheck :: Context -> Program SourcePos -> ExceptT String IO ()<commit_msg>Added in support for errors from the type resolver<commit_after>
{-|
Module      : Qux.Commands.Build

Copyright   : (c) <NAME>, 2015
License     : BSD3
Maintainer  : <EMAIL>
-}

{-# OPTIONS_HADDOCK hide, prune #-}

module Qux.Commands.Build where

import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.Reader

import qualified    Data.ByteString as BS
import              Data.List       (intercalate)

import qualified    Language.Qux.Annotated.NameResolver     as NameResolver
import              Language.Qux.Annotated.Parser           hiding (parse)
import qualified    Language.Qux.Annotated.Parser           as P
import              Language.Qux.Annotated.Syntax
import              Language.Qux.Annotated.TypeChecker
import qualified    Language.Qux.Annotated.TypeResolver     as TypeResolver
import qualified    Language.Qux.Llvm.Compiler              as C

import LLVM.General
import LLVM.General.Context hiding (Context)

import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.IO.Error


data Options = Options {
    optCompile      :: Bool,
    optDestination  :: FilePath,
    optFormat       :: Format,
    optTypeCheck    :: Bool,
    argFilePaths    :: [FilePath]
    }
    deriving (Eq, Show)

defaultOptions :: Options
defaultOptions = Options {
    optCompile      = False,
    optDestination  = "." ++ [pathSeparator],
    optFormat       = Bitcode,
    optTypeCheck    = False,
    argFilePaths    = []
    }

data Format = Assembly | Bitcode
    deriving Eq

instance Show Format where
    show Assembly   = "assembly"
    show Bitcode    = "bitcode"

-- TODO (hjw): simplify all programs as early as possible
-- TODO (hjw): re-use contexts as much as possible

handle :: Options -> IO ()
handle options = do
    let filePaths = argFilePaths options
    fileContents <- mapM readFile filePaths

    ethr <- catchIOError
        (runExceptT $ zipWithM parse filePaths fileContents >>= resolveNames >>= resolveTypes >>= build options)
        (return . Left . ioeGetErrorString)

    case ethr of
        Left error  -> hPutStrLn stderr error >> exitFailure
        Right _     -> return ()

parse :: FilePath -> String -> ExceptT String IO (Program SourcePos)
parse filePath contents = mapExceptT (return . runIdentity) (withExcept show (P.parse program filePath contents))

resolveNames :: [Program SourcePos] -> ExceptT String IO [Program SourcePos]
resolveNames programs = mapM resolve programs
    where
        resolve :: Program SourcePos -> ExceptT String IO (Program SourcePos)
        resolve program = do
            let context'            = NameResolver.context (simp program) (map simp programs)
            let (program', errors)  = NameResolver.runResolve (NameResolver.resolveProgram program) context'

            when (not $ null errors) $ throwError (intercalate "\n\n" $ map show errors)

            return program'

resolveTypes :: [Program SourcePos] -> ExceptT String IO [Program SourcePos]
resolveTypes programs = mapM resolve programs
    where
        baseContext'                    = baseContext (map simp programs)

        resolve :: Program SourcePos -> ExceptT String IO (Program SourcePos)
        resolve program@(Program _ m _) = do
            let context'            = baseContext' { module_ = map simp m }
            let (program', errors)  = TypeResolver.runResolve (TypeResolver.resolveProgram program) context'

            when (not $ null errors) $ throwError (intercalate "\n\n" $ map show errors)

            return program'

build :: Options -> [Program SourcePos] -> ExceptT String IO ()
build options programs = do
    let baseContext' = baseContext $ map simp programs

    when (optTypeCheck options) $ mapM_ (\p@(Program _ m _) -> typeCheck (baseContext' { module_ = map simp m }) p) programs
    when (optCompile options)   $ mapM_ (\p@(Program _ m _) -> compile options (baseContext' { module_ = map simp m }) p) programs

typeCheck :: Context -> Program SourcePos -> ExceptT String IO ()
{'fraction_non_alphanumeric': 0.08564844450134426, 'fraction_numerical': 0.0012802458071949814, 'mean_word_length': 2.846381093057607, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 53, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3483836', 'n_tokens_mistral': 2153, 'n_tokens_neox': 2112, 'n_words': 706}