content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE ParallelListComp #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  
  {-
    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.Requirements (checkRequirements) where
  
  import CodeWorld.Requirements.Checker.Eval
  import CodeWorld.Requirements.Checker.Language
  import CodeWorld.Requirements.Checker.Types
  import CodeWorld.Requirements.Framework
  import Codec.Compression.Zlib
  import Control.Exception
  import Control.Monad
  import Data.Array
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Base64 as B64
  import qualified Data.ByteString.Lazy as B (fromStrict, toStrict)
  import Data.Char
  import Data.Either
  import Data.Monoid
  import Data.Text (Text)
  import qualified Data.Text as T
  import Data.Text.Encoding (decodeUtf8, encodeUtf8)
  import DynFlags
  import ErrUtils
  import HsSyn
  import Language.Haskell.Exts
  import System.IO.Unsafe
  import TcRnTypes
  import Text.Regex.TDFA
  import Text.Regex.TDFA.Text
  
  checkRequirements :: DynFlags -> Messages -> TcGblEnv -> HsModule GhcPs -> ByteString -> Maybe String
  checkRequirements e c f m s = do
    let (sources, sdiags) = extractRequirementsSource s
        (reqs, rdiags) = extractRequirements sources
    if (not (null reqs))
      then
        let results = map (handleRequirement e c f m s) reqs
            obfuscated = T.unpack (obfuscate (map snd sources))
         in Just $
              "\n                      :: REQUIREMENTS ::\n"
                ++ "Obfuscated:\n\n    XREQUIRES"
                ++ obfuscated
                ++ "\n\n"
                ++ concat sdiags
                ++ concat rdiags
                ++ concat results
                ++ "                  :: END REQUIREMENTS ::\n"
      else Nothing
  
  plainPattern :: Text
  plainPattern = "{-+[[:space:]]*REQUIRES\\b((\n|[^-]|-[^}])*)-}"
  
  codedPattern :: Text
  codedPattern = "{-+[[:space:]]*XREQUIRES\\b((\n|[^-]|-[^}])*)-}"
  
  extractRequirementsSource :: ByteString -> ([(SrcSpanInfo, Text)], [String])
  extractRequirementsSource s =
    let src = decodeUtf8 s
        plain = extractSubmatches plainPattern src
        blocks = map (fmap deobfuscate) (extractSubmatches codedPattern src)
        diags =
          [ "warning: Coded requirements were corrupted.\n"
            | (spn, Nothing) <- blocks
          ]
        coded = [(spn, rule) | (spn, Just block) <- blocks, rule <- block]
     in ((plain ++ coded), diags)
  
  extractSubmatches :: Text -> Text -> [(SrcSpanInfo, Text)]
  extractSubmatches pattern src =
    [ (srcSpanFor src off len, T.take len (T.drop off src))
      | matchArray :: MatchArray <- src =~ pattern,
        rangeSize (bounds matchArray) > 1,
        let (off, len) = matchArray ! 1
    ]
  
  extractRequirements :: [(SrcSpanInfo, Text)] -> ([Requirement], [String])
  extractRequirements sources = (reqs, diags)
    where
      results =
        [ parseRequirement ln col source
          | (SrcSpanInfo spn _, source) <- sources,
            let ln = srcSpanStartLine spn,
            let col = srcSpanStartColumn spn
        ]
      diags = [format loc err | Left err <- results | (loc, _) <- sources]
      reqs = [req | Right req <- results]
      format loc err = ("error: The requirement could not be understood:\n" ++ err ++ "\n")
  
  handleRequirement :: DynFlags -> Messages -> TcGblEnv -> HsModule GhcPs -> ByteString -> Requirement -> String
  handleRequirement e c f m s req =
    let desc = requiredDescription req
        (success, msgs) = evalRequirement e c f m s req
        label
          | success == Nothing = "[?] " ++ desc ++ "\n"
          | success == Just True = "[Y] " ++ desc ++ "\n"
          | otherwise = "[N] " ++ desc ++ "\n"
     in label ++ concat ["      " ++ msg ++ "\n" | msg <- msgs]
  
  obfuscate :: [Text] -> Text
  obfuscate =
    wrapWithPrefix 60 "\n    " . decodeUtf8 . B64.encode
      . B.toStrict
      . compress
      . B.fromStrict
      . encodeUtf8
      . T.pack
      . show
      . map T.unpack
  
  deobfuscate :: Text -> Maybe [Text]
  deobfuscate =
    fmap (map T.pack . read . T.unpack . decodeUtf8)
      . partialToMaybe
      . B.toStrict
      . decompress
      . B.fromStrict
      . B64.decodeLenient
      . encodeUtf8
      . T.filter (not . isSpace)
  
  wrapWithPrefix :: Int -> Text -> Text -> Text
  wrapWithPrefix n pre txt = T.concat (parts txt)
    where
      parts t
        | T.length t < n = [pre <> t]
        | otherwise =
          let (a, b) = T.splitAt n t
           in pre <> a : parts b
  
  partialToMaybe :: a -> Maybe a
  partialToMaybe =
    (eitherToMaybe :: Either SomeException a -> Maybe a)
      . unsafePerformIO
      . try
      . evaluate
  
  eitherToMaybe :: Either a b -> Maybe b
  eitherToMaybe = either (const Nothing) Just
  