content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE PatternGuards #-}
  
  module Main (main) where
  
  import           Control.Monad (unless, foldM)
  import           Control.Monad.Error.Class (throwError)
  import           Control.Monad.IO.Class (liftIO)
  import           Control.Monad.Logger (runLogger')
  import qualified Control.Monad.State as State
  import           Control.Monad.Trans (lift)
  import           Control.Monad.Trans.Except (ExceptT(..), runExceptT)
  import           Control.Monad.Trans.Reader (runReaderT)
  import           Control.Monad.Writer.Strict (runWriterT)
  import qualified Data.Aeson as A
  import           Data.Aeson ((.=))
  import           Data.Bifunctor (first, second, bimap)
  import qualified Data.ByteString.Lazy as BL
  import           Data.Default (def)
  import           Data.Function (on)
  import qualified Data.IORef as IORef
  import           Data.List (nubBy)
  import qualified Data.List.NonEmpty as NE
  import qualified Data.Map as M
  import           Data.Set (Set)
  import qualified Data.Set as Set
  import           Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import           Data.Time.Clock (UTCTime)
  import           GHC.Generics (Generic)
  import qualified Language.PureScript as P
  import qualified Language.PureScript.CST as CST
  import qualified Language.PureScript.CST.Monad as CSTM
  import qualified Language.PureScript.CodeGen.JS as J
  import qualified Language.PureScript.CodeGen.JS.Printer as P
  import qualified Language.PureScript.CoreFn as CF
  import qualified Language.PureScript.Docs.Types as Docs
  import qualified Language.PureScript.Errors.JSON as P
  import qualified Language.PureScript.Interactive as I
  import qualified Language.PureScript.Make as Make
  import qualified Language.PureScript.Make.Cache as Cache
  import qualified Language.PureScript.Names as N
  import qualified Language.PureScript.TypeChecker.TypeSearch as TS
  import qualified Network.Wai.Handler.Warp as Warp
  import           System.Environment (getArgs)
  import           System.Exit (exitFailure)
  import           System.FilePath.Glob (glob)
  import qualified System.IO as IO
  import           Web.Scotty
  import qualified Web.Scotty as Scotty
  
  type JS = Text
  
  data Error
    = CompilerErrors [P.JSONError]
    | OtherError Text
    deriving Generic
  
  instance A.ToJSON Error
  
  toCompilerErrors :: NE.NonEmpty CST.ParserError -> Error
  toCompilerErrors = CompilerErrors . toJsonErrors . CST.toMultipleErrors "<file>"
  
  toJsonErrors :: P.MultipleErrors -> [P.JSONError]
  toJsonErrors = P.toJSONErrors False P.Error []
  
  -- As of PureScript 0.14 we only need the `codegen` part of `MakeActions` to run
  -- Try PureScript, because we already know all dependencies are compiled, we're
  -- only building one module, we don't allow FFI declarations, and we want to
  -- avoid writing to the file system as much as possible.
  buildMakeActions :: IORef.IORef (Maybe JS) -> Make.MakeActions Make.Make
  buildMakeActions codegenRef =
    Make.MakeActions
      getInputTimestampsAndHashes
      getOutputTimestamp
      readExterns
      codegen
      ffiCodegen
      progress
      readCacheDb
      writeCacheDb
      writePackageJson
      outputPrimDocs
    where
    getInputTimestampsAndHashes :: P.ModuleName -> Make.Make (Either Make.RebuildPolicy (M.Map FilePath (UTCTime, Make.Make Cache.ContentHash)))
    getInputTimestampsAndHashes _ = pure $ Right M.empty
  
    getOutputTimestamp :: P.ModuleName -> Make.Make (Maybe UTCTime)
    getOutputTimestamp _ = pure Nothing
  
    readExterns :: P.ModuleName -> Make.Make (FilePath, Maybe P.ExternsFile)
    readExterns _ = pure ("<file>", Nothing)
  
    codegen :: CF.Module CF.Ann -> Docs.Module -> P.ExternsFile -> P.SupplyT Make.Make ()
    codegen m _ _ = do
      rawJs <- J.moduleToJs m Nothing
      lift $ liftIO $ IORef.writeIORef codegenRef $ Just $ P.prettyPrintJS rawJs
  
    -- If we ever support FFI implementations in Try PureScript then we will need
    -- to implement this function. However, we do not plan to support this feature.
    ffiCodegen :: CF.Module CF.Ann -> Make.Make ()
    ffiCodegen _ = pure ()
  
    progress :: Make.ProgressMessage -> Make.Make ()
    progress _ = pure ()
  
    readCacheDb :: Make.Make Cache.CacheDb
    readCacheDb = pure M.empty
  
    writeCacheDb :: Cache.CacheDb -> Make.Make ()
    writeCacheDb _ = pure ()
  
    writePackageJson :: Make.Make ()
    writePackageJson = pure ()
  
    outputPrimDocs :: Make.Make ()
    outputPrimDocs = pure ()
  
  server :: [N.ModuleName] -> [P.ExternsFile] -> P.Env -> P.Environment -> Int -> IO ()
  server allModuleNames externs initNamesEnv initEnv port = do
    codegenRef <- IORef.newIORef Nothing
    let makeActions = buildMakeActions codegenRef
    let modNames = Set.fromList allModuleNames
    let compile :: Text -> IO (Either Error ([P.JSONError], JS))
        compile input
          | T.length input > 20000 = return $ Left $ OtherError "Please limit your input to 20000 characters"
          | otherwise = do
            case CST.parseModuleFromFile "<file>" input of
              Left parserErrors ->
                return $ Left $ toCompilerErrors parserErrors
  
              Right partialResult -> case CST.resFull partialResult of
                (_, Left parserErrors) ->
                  return $ Left $ toCompilerErrors parserErrors
  
                (parserWarnings, Right m)
                  | Set.notMember (P.getModuleName m) modNames -> do
                      (makeResult, warnings) <- Make.runMake P.defaultOptions $ Make.rebuildModule' makeActions initNamesEnv externs m
                      codegenResult <- IORef.readIORef codegenRef
                      return $ case makeResult of
                        Left errors ->
                          Left $ CompilerErrors $ toJsonErrors errors
                        Right _ | Just js <- codegenResult -> do
                          let ws = warnings <> CST.toMultipleWarnings "<file>" parserWarnings
                          Right (toJsonErrors ws, js)
                        Right _ ->
                          Left $ OtherError "Failed to read the results of codegen."
  
                  | otherwise -> do
                      let
                        modName = N.runModuleName $ P.getModuleName m
                      return $ Left $ OtherError $
                        "The name of the module you defined " <> modName <> " clashes with another module in the package set. Rename the module to something else (e.g. 'Main')."
  
    scottyOpts (getOpts port) $ do
      get "/" $
        Scotty.text "POST api.purescript.org/compile"
  
      post "/compile" $ do
        code <- T.decodeUtf8 . BL.toStrict <$> body
        response <- lift $ compile code
        Scotty.setHeader "Access-Control-Allow-Origin" "*"
        case response of
          Left err ->
            Scotty.json $ A.object [ "error" .= err ]
          Right (warnings, comp) ->
            Scotty.json $ A.object [ "js" .= comp, "warnings" .= warnings ]
  
      get "/search" $ do
        query <- param "q"
        Scotty.setHeader "Access-Control-Allow-Origin" "*"
        Scotty.setHeader "Content-Type" "application/json"
        case tryParseType query of
          Nothing -> Scotty.json $ A.object [ "error" .= ("Cannot parse type" :: Text) ]
          Just ty -> do
            let elabs = lookupAllConstructors initEnv ty
                search = fst . TS.typeSearch (Just []) initEnv (P.emptyCheckState initEnv)
                results = nubBy ((==) `on` fst) $ do
                  elab <- elabs
                  let mkSkolemType nm s = P.Skolem P.NullSourceAnn nm Nothing s (P.SkolemScope 0)
                      strictMatches = search (replaceTypeVariablesAndDesugar mkSkolemType elab)
                      flexMatches = search (replaceTypeVariablesAndDesugar (const (P.TUnknown P.NullSourceAnn)) elab)
                  take 50 (strictMatches ++ flexMatches)
            Scotty.json $ A.object [ "results" .= [ P.showQualified id k
                                                  | (k, _) <- take 50 results
                                                  ]
                                   ]
  
  getOpts :: Int -> Scotty.Options
  getOpts port = def
    { settings =
        Warp.setHost "127.0.0.1"
        $ Warp.setPort port
        $ Warp.defaultSettings
    }
  
  lookupAllConstructors :: P.Environment -> P.SourceType -> [P.SourceType]
  lookupAllConstructors env = P.everywhereOnTypesM $ \case
      P.TypeConstructor ann (P.Qualified (N.BySourcePos _) tyCon) -> P.TypeConstructor ann <$> lookupConstructor env tyCon
      other -> pure other
    where
      lookupConstructor :: P.Environment -> P.ProperName 'P.TypeName -> [P.Qualified (P.ProperName 'P.TypeName)]
      lookupConstructor env nm =
        [ q
        | (q@(P.Qualified (N.ByModuleName _) thisNm), _) <- M.toList (P.types env)
        , thisNm == nm
        ]
  
  -- | (Consistently) replace unqualified type constructors and type variables with unknowns.
  --
  -- Also remove the @ParensInType@ Constructor (we need to deal with type operators later at some point).
  replaceTypeVariablesAndDesugar :: (Text -> Int -> P.SourceType) -> P.SourceType -> P.SourceType
  replaceTypeVariablesAndDesugar f ty = State.evalState (P.everywhereOnTypesM go ty) (0, M.empty) where
    go = \case
      P.ParensInType _ ty -> pure ty
      P.TypeVar _ s -> do
        (next, m) <- State.get
        case M.lookup s m of
          Nothing -> do
            let ty = f s next
            State.put (next + 1, M.insert s ty m)
            pure ty
          Just ty -> pure ty
      other -> pure other
  
  tryParseType :: Text -> Maybe P.SourceType
  tryParseType = hush . fmap (CST.convertType "<file>") . runParser CST.parseTypeP
    where
      hush = either (const Nothing) Just
  
      runParser :: CST.Parser a -> Text -> Either String a
      runParser p =
        bimap (CST.prettyPrintError . NE.head) snd
          . CST.runTokenParser (p <* CSTM.token CST.TokEof)
          . CST.lexTopLevel
  
  main :: IO ()
  main = do
    -- Stop mangled "Compiling ModuleName" text
    IO.hSetBuffering IO.stderr IO.LineBuffering
    (portString : inputGlobs) <- getArgs
    let port = read portString
    inputFiles <- concat <$> traverse glob inputGlobs
    e <- runExceptT $ do
      modules <- ExceptT $ I.loadAllModules inputFiles
      (exts, env) <- ExceptT . I.runMake . I.make $ map (second CST.pureResult) modules
      namesEnv <- fmap fst . runWriterT $ foldM P.externsEnv P.primEnv exts
      let
        allModuleNames = fmap (P.getModuleName . snd) modules
      pure (allModuleNames, exts, namesEnv, env)
    case e of
      Left err -> print err >> exitFailure
      Right (allModuleNames, exts, namesEnv, env) -> server allModuleNames exts namesEnv env port
  