Build.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}

module Dovetail.Build where

import Control.Monad (foldM)
import Control.Monad.Supply (evalSupplyT)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (runStateT)
import Control.Monad.Trans.Writer (runWriterT)
import Data.Foldable (foldl')
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NEL
import Data.Text (Text)
import Language.PureScript qualified as P
import Language.PureScript.AST.Declarations qualified as AST
import Language.PureScript.AST.SourcePos qualified as AST
import Language.PureScript.CoreFn qualified as CoreFn
import Language.PureScript.CST qualified as CST
import Language.PureScript.Errors qualified as Errors
import Language.PureScript.Renamer qualified as Renamer
import Language.PureScript.Sugar.Names.Env qualified as Env
import Language.PureScript.TypeChecker.Monad qualified as TC

data BuildError
  = UnableToParse (NonEmpty CST.ParserError)
  | UnableToCompile Errors.MultipleErrors
  | InternalError
  deriving Show

renderBuildError :: BuildError -> String
renderBuildError (UnableToParse xs) =
  unlines $
    "Parser errors:" : NEL.toList (fmap CST.prettyPrintError xs)
renderBuildError (UnableToCompile xs) =
  Errors.prettyPrintMultipleErrors Errors.defaultPPEOptions xs
renderBuildError InternalError =
  "An internal error occurred during compilation."

-- | Parse and build a single PureScript module, returning the compiled CoreFn
-- module.
buildSingleModule :: [P.ExternsFile] -> Text -> Either BuildError (CoreFn.Module CoreFn.Ann, P.ExternsFile)
buildSingleModule externs moduleText = do
  case CST.parseFromFile "<input>" moduleText of
    (_, Left errs) ->
      Left (UnableToParse errs)
    (_, Right m) -> 
      case buildCoreFnOnly externs m of
        Left errs ->
          Left (UnableToCompile errs)
        Right (result, _) -> Right result

-- | Parse and build a single PureScript expression, returning the compiled CoreFn
-- module. The expression will be used to create a placeholder module with the name
-- @Main@, and a single expression named @main@, with the specified content.
buildSingleExpression
  :: Maybe P.ModuleName
  -- ^ The name of the "default module" whose exports will be made available unqualified
  -- to the evaluated expression.
  -> [P.ExternsFile]
  -> Text
  -> Either BuildError (CoreFn.Expr CoreFn.Ann, P.SourceType)
buildSingleExpression = buildSingleExpressionWith id

buildSingleExpressionWith
  :: (AST.Expr -> AST.Expr)
  -- ^ A function which can be used to modify the parsed syntax tree before compilation
  -> Maybe P.ModuleName
  -- ^ The name of the "default module" whose exports will be made available unqualified
  -- to the evaluated expression.
  -> [P.ExternsFile]
  -> Text
  -> Either BuildError (CoreFn.Expr CoreFn.Ann, P.SourceType)
buildSingleExpressionWith f defaultModule externs input = do
  let tokens = CST.lex input
      (_, parseResult) = CST.runParser (CST.ParserState tokens [] []) CST.parseExpr
  case parseResult of
    Left errs ->
      Left (UnableToParse errs)
    Right cst -> 
      buildSingleExpressionFromAST defaultModule externs (f (CST.convertExpr "<input>" cst))

buildSingleExpressionFromAST
  :: Maybe P.ModuleName
  -- ^ The name of the "default module" whose exports will be made available unqualified
  -- to the evaluated expression.
  -> [P.ExternsFile]
  -> AST.Expr
  -> Either BuildError (CoreFn.Expr CoreFn.Ann, P.SourceType)
buildSingleExpressionFromAST defaultModule externs expr = do
  let exprName = P.Ident "$"
      decl = AST.ValueDeclarationData
               { AST.valdeclSourceAnn  = AST.nullSourceAnn
               , AST.valdeclIdent      = exprName
               , AST.valdeclName       = P.Public
               , AST.valdeclBinders    = []
               , AST.valdeclExpression = [AST.GuardedExpr [] expr]
               }
      imports = [ P.ImportDeclaration
                    AST.nullSourceAnn
                    mn
                    P.Implicit
                    (if defaultModule == Just mn 
                       then Nothing
                       else Just mn)
                | P.ExternsFile { P.efModuleName = mn } <- externs
                ]
      m = AST.Module AST.nullSourceSpan [] (P.ModuleName "$") (imports <> [P.ValueDeclaration decl]) Nothing
  case buildCoreFnOnly externs m of 
    Left errs ->
      Left (UnableToCompile errs)
    Right ((result, externs'), _) -> 
      case (CoreFn.moduleDecls result, P.efDeclarations externs') of
        ([CoreFn.NonRec _ name1 coreFnExpr], [P.EDValue name2 ty]) 
          | name1 == exprName
          , name2 == exprName -> Right (coreFnExpr, ty)
        ([CoreFn.Rec [((_, name1), coreFnExpr)]], [P.EDValue name2 ty]) 
          | name1 == exprName
          , name2 == exprName -> Right (coreFnExpr, ty)
        _ -> Left InternalError

-- | Compile a single 'AST.Module' into a CoreFn module.
--
-- This function is based on the 'Language.PureScript.Make.rebuildModule'
-- function.
--
-- It is reproduced and modified here in order to make it simpler to build a 
-- single module without all of the additional capabilities and complexity of
-- the upstream API.
buildCoreFnOnly
  :: [P.ExternsFile]
  -> AST.Module
  -> Either Errors.MultipleErrors ((CoreFn.Module CoreFn.Ann, P.ExternsFile), Errors.MultipleErrors)
buildCoreFnOnly externs m@(AST.Module _ _ moduleName _ _) = runWriterT $ do
  let withPrim = P.importPrim m
      env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
  exEnv <- fmap fst . runWriterT $ foldM P.externsEnv Env.primEnv externs
  evalSupplyT 0 $ do
    (desugared, (exEnv', _)) <- runStateT (P.desugar externs withPrim) (exEnv, mempty)
    let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'
    (checked, TC.CheckState{..}) <- runStateT (P.typeCheckModule modulesExports desugared) $ TC.emptyCheckState env
    let AST.Module ss coms _ elaborated exps = checked
    deguarded <- P.desugarCaseGuards elaborated
    regrouped <- lift . P.createBindingGroups moduleName . P.collapseBindingGroups $ deguarded
    let mod' = AST.Module ss coms moduleName regrouped exps
        corefn = CoreFn.moduleToCoreFn checkEnv mod'
        optimized = CoreFn.optimizeCoreFn corefn
        (renamedIdents, renamed) = Renamer.renameInModule optimized
        newExterns = P.moduleToExternsFile mod' checkEnv renamedIdents
    pure (renamed, newExterns)