<commit_before>{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module CodeWorld.Compile.Stages
  ( findAllModules,
    getExtraPkgs,
    checkDangerousSource,
    checkCodeConventions,
    checkRequirements,
  )
where

import CodeWorld.Compile.Framework
import CodeWorld.Compile.Requirements
import Control.Monad
import Control.Monad.State
import Data.Array
import Data.Function (on)
import Data.Generics
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8)
import qualified "ghc" FastString as GHC
import qualified "ghc" HsSyn as GHC
import Language.Haskell.Exts
import qualified "ghc" BasicTypes as GHC
import qualified "ghc" Module as GHC
import qualified "ghc" OccName as GHC
import qualified "ghc" RdrName as GHC
import qualified "ghc" SrcLoc as GHC
import System.FilePath
import System.IO.Temp
import Text.Regex.TDFA
import Text.Regex.TDFA.Text

-- Expands the source list to include modules that are imported and
-- found by the module finder.
findAllModules :: MonadCompile m => m ()
findAllModules = do
  startPaths <- gets compileSourcePaths
  newPaths <-
    M.elems
      <$> execStateT (mapM_ (findImportsInModule Nothing) startPaths) M.empty
  modify $ \state -> state {compileSourcePaths = startPaths ++ newPaths}

findImportsInModule ::
  MonadCompile m =>
  Maybe SrcSpanInfo ->
  FilePath ->
  StateT (M.Map String FilePath) m ()
findImportsInModule topLoc path = do
  parsed <- lift $ getGHCParsedCode path
  case parsed of
    GHCParsed mod -> do
      forM_ (GHC.hsmodImports mod) $ \(GHC.L loc idecl) ->
        findModule (fromMaybe (convertSpan loc) topLoc)
          $ GHC.moduleNameString
          $ GHC.unLoc
          $ GHC.ideclName idecl
      findModule (fromMaybe defaultSpan topLoc) "Prelude"
    _ -> return ()
  where
    convertSpan span = case (GHC.srcSpanStart span, GHC.srcSpanEnd span) of
      (GHC.RealSrcLoc start, GHC.RealSrcLoc end) ->
        SrcSpanInfo
          ( SrcSpan
              (GHC.unpackFS $ GHC.srcLocFile start)
              (GHC.srcLocLine start)
              (GHC.srcLocCol start)
              (GHC.srcLocLine end)
              (GHC.srcLocCol end)
          )
          []
      _ -> noSrcSpan
    defaultSpan = SrcSpanInfo (SrcSpan (takeFileName path) 1 1 1 1) []

findModule ::
  MonadCompile m => SrcSpanInfo -> String -> StateT (M.Map String FilePath) m ()
findModule loc modName = do
  mode <- lift $ gets compileMode
  alreadyFound <- get
  if M.member modName alreadyFound
    then return ()
    else do
      finder <- lift $ gets compileModuleFinder
      orig <- liftIO (finder modName)
      case orig of
        Nothing -> return ()
        Just f -> do
          copyResult <- lift $ copyModuleWithTransform f (transform mode)
          case copyResult of
            Just copy -> do
              lift $ modify $ \cs ->
                cs
                  { compileImportLocations =
                      M.insert (takeFileName copy) loc (compileImportLocations cs)
                  }
              modify (M.insert modName copy)
              findImportsInModule (Just loc) copy
            _ -> do
              -- Make up a fake file just to contain the error.  The actual
              -- error message shouldn't matter, because it will be
              -- replaced later.
              buildDir <- lift $ gets compileBuildDir
              f <- liftIO $ emptyTempFile buildDir "failedimport.hs"
              lift $ modify $ \cs ->
                cs
                  { compileImportLocations =
                      M.insert (takeFileName f) loc (compileImportLocations cs)
                  }
              modify (M.insert modName f)
              lift $
                addDiagnostics
                  [ ( SrcSpanInfo (SrcSpan (takeFileName f) 1 1 1 1) [],
                      CompileError,
                      "error: Parse error."
                    )
                  ]
  where
    transform "codeworld" = renameIdentInModule "program" . renameModule
    transform _ = renameIdentInModule "main" . renameModule
    renameModule mod =
      mod {GHC.hsmodName = Just (GHC.noLoc (GHC.mkModuleName modName))}
    renameIdentInModule ident = everywhere (mkT (renameIdent ident))
    renameIdent :: String -> GHC.RdrName -> GHC.RdrName
    renameIdent ident (GHC.Unqual n)
      | n == GHC.mkVarOcc ident = GHC.Unqual (GHC.mkVarOcc (renamed ident))
    renameIdent ident (GHC.Qual qualifier n)
      | n == GHC.mkVarOcc ident = GHC.Qual qualifier (GHC.mkVarOcc (renamed ident))
    renameIdent _ other = other
    renamed ident = ident ++ "_" ++ map dotToUnderscore modName
    dotToUnderscore '.' = '_'
    dotToUnderscore c = c

-- Look for package imports.  We want to add these packages to the
-- command line.
getExtraPkgs :: MonadCompile m => m [String]
getExtraPkgs = do
  srcs <- gets compileSourcePaths
  fmap nub . fmap concat . forM srcs $ \src ->
    getGHCParsedCode src >>= \parsed -> case parsed of
      GHCParsed mod -> do
        return . catMaybes . flip map (GHC.hsmodImports mod) $ \i -> case i of
          GHC.L _ (GHC.ImportDecl { GHC.ideclPkgQual = Just pkg }) ->
            Just (GHC.unpackFS (GHC.sl_fs pkg))
          _ -> Nothing<commit_msg>Run format.sh again<commit_after>{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module CodeWorld.Compile.Stages
  ( findAllModules,
    getExtraPkgs,
    checkDangerousSource,
    checkCodeConventions,
    checkRequirements,
  )
where

import qualified "ghc" BasicTypes as GHC
import CodeWorld.Compile.Framework
import CodeWorld.Compile.Requirements
import Control.Monad
import Control.Monad.State
import Data.Array
import Data.Function (on)
import Data.Generics
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Text (Text, unpack)
import Data.Text.Encoding (decodeUtf8)
import qualified "ghc" FastString as GHC
import qualified "ghc" HsSyn as GHC
import Language.Haskell.Exts
import qualified "ghc" Module as GHC
import qualified "ghc" OccName as GHC
import qualified "ghc" RdrName as GHC
import qualified "ghc" SrcLoc as GHC
import System.FilePath
import System.IO.Temp
import Text.Regex.TDFA
import Text.Regex.TDFA.Text

-- Expands the source list to include modules that are imported and
-- found by the module finder.
findAllModules :: MonadCompile m => m ()
findAllModules = do
  startPaths <- gets compileSourcePaths
  newPaths <-
    M.elems
      <$> execStateT (mapM_ (findImportsInModule Nothing) startPaths) M.empty
  modify $ \state -> state {compileSourcePaths = startPaths ++ newPaths}

findImportsInModule ::
  MonadCompile m =>
  Maybe SrcSpanInfo ->
  FilePath ->
  StateT (M.Map String FilePath) m ()
findImportsInModule topLoc path = do
  parsed <- lift $ getGHCParsedCode path
  case parsed of
    GHCParsed mod -> do
      forM_ (GHC.hsmodImports mod) $ \(GHC.L loc idecl) ->
        findModule (fromMaybe (convertSpan loc) topLoc)
          $ GHC.moduleNameString
          $ GHC.unLoc
          $ GHC.ideclName idecl
      findModule (fromMaybe defaultSpan topLoc) "Prelude"
    _ -> return ()
  where
    convertSpan span = case (GHC.srcSpanStart span, GHC.srcSpanEnd span) of
      (GHC.RealSrcLoc start, GHC.RealSrcLoc end) ->
        SrcSpanInfo
          ( SrcSpan
              (GHC.unpackFS $ GHC.srcLocFile start)
              (GHC.srcLocLine start)
              (GHC.srcLocCol start)
              (GHC.srcLocLine end)
              (GHC.srcLocCol end)
          )
          []
      _ -> noSrcSpan
    defaultSpan = SrcSpanInfo (SrcSpan (takeFileName path) 1 1 1 1) []

findModule ::
  MonadCompile m => SrcSpanInfo -> String -> StateT (M.Map String FilePath) m ()
findModule loc modName = do
  mode <- lift $ gets compileMode
  alreadyFound <- get
  if M.member modName alreadyFound
    then return ()
    else do
      finder <- lift $ gets compileModuleFinder
      orig <- liftIO (finder modName)
      case orig of
        Nothing -> return ()
        Just f -> do
          copyResult <- lift $ copyModuleWithTransform f (transform mode)
          case copyResult of
            Just copy -> do
              lift $ modify $ \cs ->
                cs
                  { compileImportLocations =
                      M.insert (takeFileName copy) loc (compileImportLocations cs)
                  }
              modify (M.insert modName copy)
              findImportsInModule (Just loc) copy
            _ -> do
              -- Make up a fake file just to contain the error.  The actual
              -- error message shouldn't matter, because it will be
              -- replaced later.
              buildDir <- lift $ gets compileBuildDir
              f <- liftIO $ emptyTempFile buildDir "failedimport.hs"
              lift $ modify $ \cs ->
                cs
                  { compileImportLocations =
                      M.insert (takeFileName f) loc (compileImportLocations cs)
                  }
              modify (M.insert modName f)
              lift $
                addDiagnostics
                  [ ( SrcSpanInfo (SrcSpan (takeFileName f) 1 1 1 1) [],
                      CompileError,
                      "error: Parse error."
                    )
                  ]
  where
    transform "codeworld" = renameIdentInModule "program" . renameModule
    transform _ = renameIdentInModule "main" . renameModule
    renameModule mod =
      mod {GHC.hsmodName = Just (GHC.noLoc (GHC.mkModuleName modName))}
    renameIdentInModule ident = everywhere (mkT (renameIdent ident))
    renameIdent :: String -> GHC.RdrName -> GHC.RdrName
    renameIdent ident (GHC.Unqual n)
      | n == GHC.mkVarOcc ident = GHC.Unqual (GHC.mkVarOcc (renamed ident))
    renameIdent ident (GHC.Qual qualifier n)
      | n == GHC.mkVarOcc ident = GHC.Qual qualifier (GHC.mkVarOcc (renamed ident))
    renameIdent _ other = other
    renamed ident = ident ++ "_" ++ map dotToUnderscore modName
    dotToUnderscore '.' = '_'
    dotToUnderscore c = c

-- Look for package imports.  We want to add these packages to the
-- command line.
getExtraPkgs :: MonadCompile m => m [String]
getExtraPkgs = do
  srcs <- gets compileSourcePaths
  fmap nub . fmap concat . forM srcs $ \src ->
    getGHCParsedCode src >>= \parsed -> case parsed of
      GHCParsed mod -> do
        return . catMaybes . flip map (GHC.hsmodImports mod) $ \i -> case i of
          GHC.L _ (GHC.ImportDecl {GHC.ideclPkgQual = Just pkg}) ->
            Just (GHC.unpackFS (GHC.sl_fs pkg))
          _ -> Nothing
{'fraction_non_alphanumeric': 0.0835108998524832, 'fraction_numerical': 0.0027864284543517455, 'mean_word_length': 2.3709944751381213, 'pattern_counts': {'":': 0, '<': 27, '<?xml version=': 0, '>': 65, 'https://': 0, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5210904', 'n_tokens_mistral': 3681, 'n_tokens_neox': 3574, 'n_words': 1157}