<commit_before>-----------------------------------------------------------------------------
--
-- Module      :  Compiler
-- Copyright   :  (c) <NAME> 2013-14
-- License     :  MIT
--
-- Maintainer  :  <NAME> <<EMAIL>>
-- Stability   :  experimental
-- Portability :
--
-- | psc frontend to the PureScript library
--
-----------------------------------------------------------------------------

module Compiler where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Array (concat, map)
import Data.Either

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.Exception

import Control.Apply
import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.Error.Trans
import Control.Monad.Error.Class
import Control.Monad.Cont.Trans

import Node.Args

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

foreign import data FS :: !

foreign import data Process :: !

foreign import exit
  "function exit(code) {\
  \  return function() {\
  \    process.exit(code);\
  \  };\
  \}" :: forall eff. Number -> Eff (process :: Process | eff) {}

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('fs').readFileSync(filename, 'utf8'));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (String -> r) -> (String -> r) -> Eff (fs :: FS | eff) r

type AppMonad eff = ErrorT String (Eff (fs :: FS | eff))

runAppMonad :: forall eff a. AppMonad eff a -> Eff (fs :: FS | eff) (Either String a)
runAppMonad app = runErrorT app

readFileApp :: forall eff. String -> AppMonad eff String
readFileApp filename = ErrorT $ readFile filename Right Left

preludeFilename :: String
preludeFilename = "prelude/prelude.purs"

modulesFromText :: String -> Either String [Module]
modulesFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModules tokens
  
readInput :: forall eff. [String] -> AppMonad eff [Module]
readInput input = 
  concat <$> for input (\inputFile -> do
    text <- readFileApp inputFile
    case modulesFromText text of
      Left err -> throwError err
      Right ms -> return ms)

runCompiler :: forall eff. Options -> [String] -> Maybe String -> Maybe String -> Eff (trace :: Trace, fs :: FS, process :: Process | eff) {}
runCompiler opts input output externs = do
  modules <- runAppMonad (readInput input) 
  case modules of
    Left err -> do
      trace err
      exit 1
    Right ms -> do
      case compile opts ms of
        Left err -> do
          trace err
          exit 1
        Right (Tuple3 js exts _) -> do
          case output of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path js
            Nothing -> trace js
          case externs of
            Just path -> trace "Not implemented" -- mkdirp path >> U.writeFile path exts
            Nothing -> return {}
          exit 0

flag :: String -> String -> Args Boolean
flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm)

useStdIn :: Args Boolean
useStdIn = flag "s" "stdin"

inputFiles :: Args [String]
inputFiles = many argOnly

outputFile :: Args (Maybe String)
outputFile = opt (flagArg "o" <|> flagArg "output")

externsFile :: Args (Maybe String)
externsFile = opt (flagArg "e" <|> flagArg "externs")

noTco :: Args Boolean
noTco = flagOpt "no-tco"

performRuntimeTypeChecks :: Args Boolean
performRuntimeTypeChecks = flagOpt "runtime-type-checks"

noPrelude :: Args Boolean
noPrelude = flagOpt "no-prelude"

noMagicDo :: Args Boolean
noMagicDo = flagOpt "no-magic-do"

runMain :: Args (Maybe String)
runMain = opt (flagArg "main")

noOpts :: Args Boolean
noOpts = flagOpt "no-opts"

browserNamespace :: Args String
browserNamespace = flagArg "browser-namespace" <|> pure "PS"

dceModules :: Args [String]
dceModules = many (flagArg "m" <|> flagArg "module")

codeGenModules :: Args [String]
codeGenModules = many (flagArg "codegen")

verboseErrors :: Args Boolean
verboseErrors = flag "v" "verbose-errors"

options :: Args Options
options = mkOptions <$> noPrelude 
                    <*> noTco 
                    <*> performRuntimeTypeChecks 
                    <*> noMagicDo 
                    <*> runMain 
                    <*> noOpts 
                    <*> (Just <$> browserNamespace) 
                    <*> dceModules 
                    <*> codeGenModules 
                    <*> verboseErrors

inputFilesAndPrelude :: Args [String]
inputFilesAndPrelude = combine <$> noPrelude <*> inputFiles
  where
  combine true  input = input
  combine false input = preludeFilename : input

term :: Args (Eff (trace :: Trace, fs :: FS, process :: Process) {})
term = runCompiler <$> options <*> inputFilesAndPrelude <*> outputFile <*> externsFile

main = catchException (\err -> print err) $ readArgs' term
<commit_msg>Implement writeFile, support --output and --externs<commit_after>-----------------------------------------------------------------------------
--
-- Module      :  Compiler
-- Copyright   :  (c) <NAME> 2013-14
-- License     :  MIT
--
-- Maintainer  :  <NAME> <<EMAIL>>
-- Stability   :  experimental
-- Portability :
--
-- | psc frontend to the PureScript library
--
-----------------------------------------------------------------------------

module Compiler where

import Debug.Trace

import Data.Maybe
import Data.Tuple
import Data.Tuple3
import Data.Array (concat, map)
import Data.Either

import Data.Traversable (for)

import Control.Monad.Eff
import Control.Monad.Eff.Unsafe
import Control.Monad.Eff.Exception

import Control.Apply
import Control.Monad.Trans
import Control.Monad.Identity
import Control.Monad.State.Class
import Control.Monad.Error.Trans
import Control.Monad.Error.Class
import Control.Monad.Cont.Trans

import Node.Args

import Language.PureScript
import Language.PureScript.Declarations
import Language.PureScript.Options

import qualified Language.PureScript.Parser.Lexer as P
import qualified Language.PureScript.Parser.Common as P
import qualified Language.PureScript.Parser.Declarations as P

foreign import data FS :: !

foreign import data Process :: !

foreign import exit
  "function exit(code) {\
  \  return function() {\
  \    process.exit(code);\
  \  };\
  \}" :: forall eff. Number -> Eff (process :: Process | eff) {}

foreign import readFile
  "function readFile(filename) {\
  \  return function(k) {\
  \    return function(fail) {\
  \      return function() {\
  \        try {\
  \          return k(require('fs').readFileSync(filename, 'utf8'));\
  \        } catch(err) {\
  \          return fail(err);\
  \        }\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> (String -> r) -> (String -> r) -> Eff (fs :: FS | eff) r
  
foreign import writeFile
  "function writeFile(filename) {\
  \  return function(data) {\
  \    return function(k) {\
  \      return function(fail) {\
  \        return function() {\
  \          try {\
  \            return k(require('fs').writeFileSync(filename, data, 'utf8'));\
  \          } catch(err) {\
  \            return fail(err);\
  \          }\
  \        };\
  \      };\
  \    };\
  \  };\
  \}" :: forall eff r. String -> String -> ({} -> r) -> (String -> r) -> Eff (fs :: FS | eff) r

type AppEffects = (fs :: FS, trace :: Trace, process :: Process)

type AppMonad = ErrorT String (Eff AppEffects)

runAppMonad :: forall a. AppMonad a -> Eff AppEffects {}
runAppMonad app = do
  result <- runErrorT app
  case result of
    Left err -> do
      trace err
      exit 1
    Right _ -> exit 0

readFileApp :: String -> AppMonad String
readFileApp filename = ErrorT $ readFile filename Right Left

writeFileApp :: String -> String -> AppMonad {}
writeFileApp filename text = ErrorT $ writeFile filename text Right Left

eitherApp :: forall a. Either String a -> AppMonad a
eitherApp e = ErrorT (return e)

preludeFilename :: String
preludeFilename = "prelude/prelude.purs"

modulesFromText :: String -> Either String [Module]
modulesFromText text = do
  tokens <- P.lex text
  P.runTokenParser P.parseModules tokens
  
readInput :: forall eff. [String] -> AppMonad [Module]
readInput input = 
  concat <$> for input (\inputFile -> do
    text <- readFileApp inputFile
    case modulesFromText text of
      Left err -> throwError err
      Right ms -> return ms)

runCompiler :: forall eff. Options -> [String] -> Maybe String -> Maybe String -> Eff AppEffects {}
runCompiler opts input output externs = runAppMonad do
  modules <- readInput input
  Tuple3 js exts _ <- eitherApp $ compile opts modules
  case output of
    Just path -> writeFileApp path js
    Nothing -> lift $ trace js
  case externs of
    Just path -> writeFileApp path exts
    Nothing -> return {}

flag :: String -> String -> Args Boolean
flag shortForm longForm = maybe false (const true) <$> opt (flagOnly shortForm <|> flagOnly longForm)

useStdIn :: Args Boolean
useStdIn = flag "s" "stdin"

inputFiles :: Args [String]
inputFiles = many argOnly

outputFile :: Args (Maybe String)
outputFile = opt (flagArg "o" <|> flagArg "output")

externsFile :: Args (Maybe String)
externsFile = opt (flagArg "e" <|> flagArg "externs")

noTco :: Args Boolean
noTco = flagOpt "no-tco"

performRuntimeTypeChecks :: Args Boolean
performRuntimeTypeChecks = flagOpt "runtime-type-checks"

noPrelude :: Args Boolean
noPrelude = flagOpt "no-prelude"

noMagicDo :: Args Boolean
noMagicDo = flagOpt "no-magic-do"

runMain :: Args (Maybe String)
runMain = opt (flagArg "main")

noOpts :: Args Boolean
noOpts = flagOpt "no-opts"

browserNamespace :: Args String
browserNamespace = flagArg "browser-namespace" <|> pure "PS"

dceModules :: Args [String]
dceModules = many (flagArg "m" <|> flagArg "module")

codeGenModules :: Args [String]
codeGenModules = many (flagArg "codegen")

verboseErrors :: Args Boolean
verboseErrors = flag "v" "verbose-errors"

options :: Args Options
options = mkOptions <$> noPrelude 
                    <*> noTco 
                    <*> performRuntimeTypeChecks 
                    <*> noMagicDo 
                    <*> runMain 
                    <*> noOpts 
                    <*> (Just <$> browserNamespace) 
                    <*> dceModules 
                    <*> codeGenModules 
                    <*> verboseErrors

inputFilesAndPrelude :: Args [String]
inputFilesAndPrelude = combine <$> noPrelude <*> inputFiles
  where
  combine true  input = input
  combine false input = preludeFilename : input

term :: Args (Eff AppEffects {})
term = runCompiler <$> options <*> inputFilesAndPrelude <*> outputFile <*> externsFile

main = catchException (\err -> print err) $ readArgs' term

{'fraction_non_alphanumeric': 0.14221096435679392, 'fraction_numerical': 0.002171159761172426, 'mean_word_length': 2.4973109775387536, 'pattern_counts': {'":': 0, '<': 67, '<?xml version=': 0, '>': 126, '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': '1601960', 'n_tokens_mistral': 3342, 'n_tokens_neox': 3263, 'n_words': 1005}