{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}

{-
  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.Requirements.Framework where

import qualified Config as GHCParse
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.State
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.List (foldl', intercalate, isPrefixOf)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified DynFlags as GHCParse
import qualified FastString as GHCParse
import qualified Fingerprint as GHCParse
import qualified GHC.LanguageExtensions.Type as GHCParse
import qualified HeaderInfo as GHCParse
import qualified HsExtension as GHCParse
import qualified HsSyn as GHCParse
import qualified HscTypes as GHCParse
import Language.Haskell.Exts
import qualified Lexer as GHCParse
import qualified Panic as GHCParse
import qualified Parser as GHCParse
import qualified Platform as GHCParse
import qualified SrcLoc as GHCParse
import qualified StringBuffer as GHCParse
import System.Directory
import System.Exit (ExitCode (..))
import System.FilePath
import System.IO
import System.IO.Temp (withSystemTempDirectory)
import System.Process

data GHCParsedCode = GHCParsed (GHCParse.HsModule GHCParse.GhcPs) | GHCNoParse

ghcExtensionsByName :: Map String GHCParse.Extension
ghcExtensionsByName =
  M.fromList
    [ (GHCParse.flagSpecName spec, GHCParse.flagSpecFlag spec)
      | spec <- GHCParse.xFlags
    ]

applyExtensionToFlags :: GHCParse.DynFlags -> String -> GHCParse.DynFlags
applyExtensionToFlags dflags name
  | "No" `isPrefixOf` name =
    GHCParse.xopt_unset dflags $ fromJust $ M.lookup (drop 2 name) ghcExtensionsByName
  | otherwise =
    GHCParse.xopt_set dflags $ fromJust $ M.lookup name ghcExtensionsByName

ghcParseCode :: GHCParse.DynFlags -> [String] -> Text -> GHCParsedCode
ghcParseCode flags exts src = do
  let buffer = GHCParse.stringToStringBuffer (T.unpack src)
      dflags = foldl' applyExtensionToFlags flags exts
      location = GHCParse.mkRealSrcLoc (GHCParse.mkFastString "program.hs") 1 1
      state = GHCParse.mkPState dflags buffer location
  case GHCParse.unP GHCParse.parseModule state of
    GHCParse.POk _ (GHCParse.L _ mod) -> GHCParsed mod
    GHCParse.PFailed _ _ _ -> GHCNoParse

formatLocation :: SrcSpanInfo -> String
formatLocation spn@(SrcSpanInfo (SrcSpan fn l1 c1 l2 c2) _)
  | spn == noSrcSpan = ""
  | l1 /= l2 =
    fn ++ ":(" ++ show l1 ++ "," ++ show c1 ++ ")-("
      ++ show l2
      ++ ","
      ++ show (max 1 (c2 - 1))
      ++ ")"
  | c1 < c2 - 1 =
    fn ++ ":" ++ show l1 ++ ":" ++ show c1 ++ "-"
      ++ show (max 1 (c2 - 1))
  | otherwise = fn ++ ":" ++ show l1 ++ ":" ++ show c1

srcSpanFor :: Text -> Int -> Int -> SrcSpanInfo
srcSpanFor src off len =
  SrcSpanInfo (SrcSpan "program.hs" ln1 col1 ln2 col2) []
  where
    (_, ln1, col1) = T.foldl' next (off, 1, 1) pre
    (_, ln2, col2) = T.foldl' next (len, ln1, col1) mid
    (pre, post) = T.splitAt off src
    mid = T.take len post
    next (!n, !ln, !col) '\r' = (n - 1, ln, col)
    next (!n, !ln, !col) '\n' = (n - 1, ln + 1, 1)
    next (!n, !ln, !col) '\t' = (n - 1, ln, col + 8 - (col - 1) `mod` 8)
    next (!n, !ln, !col) _ = (n - 1, ln, col + 1)
