{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Some convenient functions for putting together the whole Swarm
-- language processing pipeline: parsing, type checking, capability
-- checking, and elaboration.  If you want to simply turn some raw
-- text representing a Swarm program into something useful, this is
-- probably the module you want.
module Swarm.Language.Pipeline (
  -- * Pipeline functions
  processTerm,
  processParsedTerm,
  processTerm',
  processParsedTerm',
  processTermEither,

  -- * Utilities
  extractTCtx,
  extractReqCtx,
) where

import Control.Lens ((^.))
import Data.Bifunctor (first)
import Data.Text (Text)
import Data.Text qualified as T
import Swarm.Language.Context qualified as Ctx
import Swarm.Language.Elaborate
import Swarm.Language.Parser (readTerm)
import Swarm.Language.Pretty
import Swarm.Language.Requirements.Type (ReqCtx)
import Swarm.Language.Syntax
import Swarm.Language.Typecheck
import Swarm.Language.Types (TCtx)
import Swarm.Language.Value (Env, envReqs, envTydefs, envTypes)

processTermEither :: Text -> Either Text TSyntax
processTermEither :: Text -> Either Text TSyntax
processTermEither Text
t = case Text -> Either Text (Maybe TSyntax)
processTerm Text
t of
  Left Text
err -> Text -> Either Text TSyntax
forall a b. a -> Either a b
Left (Text -> Either Text TSyntax) -> Text -> Either Text TSyntax
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords [Text
"Could not parse term:", Text
err]
  Right Maybe TSyntax
Nothing -> Text -> Either Text TSyntax
forall a b. a -> Either a b
Left Text
"Term was only whitespace"
  Right (Just TSyntax
pt) -> TSyntax -> Either Text TSyntax
forall a b. b -> Either a b
Right TSyntax
pt

-- | Given a 'Text' value representing a Swarm program,
--
--   1. Parse it (see "Swarm.Language.Parse")
--   2. Typecheck it (see "Swarm.Language.Typecheck")
--   3. Elaborate it (see "Swarm.Language.Elaborate")
--
--   Return either the end result (or @Nothing@ if the input was only
--   whitespace) or a pretty-printed error message.
processTerm :: Text -> Either Text (Maybe TSyntax)
processTerm :: Text -> Either Text (Maybe TSyntax)
processTerm = Env -> Text -> Either Text (Maybe TSyntax)
processTerm' Env
forall a. Monoid a => a
mempty

-- | Like 'processTerm', but use a term that has already been parsed.
processParsedTerm :: Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm :: Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm = Env -> Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm' Env
forall a. Monoid a => a
mempty

-- | Like 'processTerm', but use explicit starting contexts.
processTerm' :: Env -> Text -> Either Text (Maybe TSyntax)
processTerm' :: Env -> Text -> Either Text (Maybe TSyntax)
processTerm' Env
e Text
txt = do
  Maybe Syntax
mt <- Text -> Either Text (Maybe Syntax)
readTerm Text
txt
  (ContextualTypeErr -> Text)
-> Either ContextualTypeErr (Maybe TSyntax)
-> Either Text (Maybe TSyntax)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> ContextualTypeErr -> Text
prettyTypeErrText Text
txt) (Either ContextualTypeErr (Maybe TSyntax)
 -> Either Text (Maybe TSyntax))
-> Either ContextualTypeErr (Maybe TSyntax)
-> Either Text (Maybe TSyntax)
forall a b. (a -> b) -> a -> b
$ (Syntax -> Either ContextualTypeErr TSyntax)
-> Maybe Syntax -> Either ContextualTypeErr (Maybe TSyntax)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Env -> Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm' Env
e) Maybe Syntax
mt

-- | Like 'processTerm'', but use a term that has already been parsed.
processParsedTerm' :: Env -> Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm' :: Env -> Syntax -> Either ContextualTypeErr TSyntax
processParsedTerm' Env
e Syntax
t = do
  TSyntax
tt <- TCtx
-> ReqCtx -> TDCtx -> Syntax -> Either ContextualTypeErr TSyntax
inferTop (Env
e Env -> Getting TCtx Env TCtx -> TCtx
forall s a. s -> Getting a s a -> a
^. Getting TCtx Env TCtx
Lens' Env TCtx
envTypes) (Env
e Env -> Getting ReqCtx Env ReqCtx -> ReqCtx
forall s a. s -> Getting a s a -> a
^. Getting ReqCtx Env ReqCtx
Lens' Env ReqCtx
envReqs) (Env
e Env -> Getting TDCtx Env TDCtx -> TDCtx
forall s a. s -> Getting a s a -> a
^. Getting TDCtx Env TDCtx
Lens' Env TDCtx
envTydefs) Syntax
t
  TSyntax -> Either ContextualTypeErr TSyntax
forall a. a -> Either ContextualTypeErr a
forall (m :: * -> *) a. Monad m => a -> m a
return (TSyntax -> Either ContextualTypeErr TSyntax)
-> TSyntax -> Either ContextualTypeErr TSyntax
forall a b. (a -> b) -> a -> b
$ TSyntax -> TSyntax
elaborate TSyntax
tt

------------------------------------------------------------
-- Some utility functions
------------------------------------------------------------

-- | Extract a type context from type annotations on definitions
--   contained in a term.  Should probably only be used for testing.
extractTCtx :: Syntax' ty -> TCtx
extractTCtx :: forall ty. Syntax' ty -> TCtx
extractTCtx (Syntax' SrcLoc
_ Term' ty
t Comments
_ ty
_) = Term' ty -> TCtx
forall {ty}. Term' ty -> TCtx
extractTCtxTerm Term' ty
t
 where
  extractTCtxTerm :: Term' ty -> TCtx
extractTCtxTerm = \case
    SLet LetSyntax
_ Bool
_ (LV SrcLoc
_ Text
x) Maybe Polytype
mty Maybe Requirements
_ Syntax' ty
_ Syntax' ty
t2 -> (TCtx -> TCtx)
-> (Polytype -> TCtx -> TCtx) -> Maybe Polytype -> TCtx -> TCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCtx -> TCtx
forall a. a -> a
id (Text -> Polytype -> TCtx -> TCtx
forall t. Text -> t -> Ctx t -> Ctx t
Ctx.addBinding Text
x) Maybe Polytype
mty (Syntax' ty -> TCtx
forall ty. Syntax' ty -> TCtx
extractTCtx Syntax' ty
t2)
    SBind Maybe LocVar
mx Maybe ty
_ Maybe Polytype
mty Maybe Requirements
_ Syntax' ty
c1 Syntax' ty
c2 ->
      (TCtx -> TCtx)
-> ((Text, Polytype) -> TCtx -> TCtx)
-> Maybe (Text, Polytype)
-> TCtx
-> TCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        TCtx -> TCtx
forall a. a -> a
id
        ((Text -> Polytype -> TCtx -> TCtx)
-> (Text, Polytype) -> TCtx -> TCtx
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Polytype -> TCtx -> TCtx
forall t. Text -> t -> Ctx t -> Ctx t
Ctx.addBinding)
        ((,) (Text -> Polytype -> (Text, Polytype))
-> (LocVar -> Text) -> LocVar -> Polytype -> (Text, Polytype)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocVar -> Text
lvVar (LocVar -> Polytype -> (Text, Polytype))
-> Maybe LocVar -> Maybe (Polytype -> (Text, Polytype))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocVar
mx Maybe (Polytype -> (Text, Polytype))
-> Maybe Polytype -> Maybe (Text, Polytype)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Polytype
mty)
        (Syntax' ty -> TCtx
forall ty. Syntax' ty -> TCtx
extractTCtx Syntax' ty
c1 TCtx -> TCtx -> TCtx
forall a. Semigroup a => a -> a -> a
<> Syntax' ty -> TCtx
forall ty. Syntax' ty -> TCtx
extractTCtx Syntax' ty
c2)
    SAnnotate Syntax' ty
t1 Polytype
_ -> Syntax' ty -> TCtx
forall ty. Syntax' ty -> TCtx
extractTCtx Syntax' ty
t1
    Term' ty
_ -> TCtx
forall a. Monoid a => a
mempty

-- | Extract a requirements context from requirements annotations on
--   definitions contained in a term.  Should probably only be used
--   for testing.
extractReqCtx :: Syntax' ty -> ReqCtx
extractReqCtx :: forall ty. Syntax' ty -> ReqCtx
extractReqCtx (Syntax' SrcLoc
_ Term' ty
t Comments
_ ty
_) = Term' ty -> ReqCtx
forall {ty}. Term' ty -> ReqCtx
extractReqCtxTerm Term' ty
t
 where
  extractReqCtxTerm :: Term' ty -> ReqCtx
extractReqCtxTerm = \case
    SLet LetSyntax
_ Bool
_ (LV SrcLoc
_ Text
x) Maybe Polytype
_ Maybe Requirements
mreq Syntax' ty
_ Syntax' ty
t2 -> (ReqCtx -> ReqCtx)
-> (Requirements -> ReqCtx -> ReqCtx)
-> Maybe Requirements
-> ReqCtx
-> ReqCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReqCtx -> ReqCtx
forall a. a -> a
id (Text -> Requirements -> ReqCtx -> ReqCtx
forall t. Text -> t -> Ctx t -> Ctx t
Ctx.addBinding Text
x) Maybe Requirements
mreq (Syntax' ty -> ReqCtx
forall ty. Syntax' ty -> ReqCtx
extractReqCtx Syntax' ty
t2)
    SBind Maybe LocVar
mx Maybe ty
_ Maybe Polytype
_ Maybe Requirements
mreq Syntax' ty
c1 Syntax' ty
c2 ->
      (ReqCtx -> ReqCtx)
-> ((Text, Requirements) -> ReqCtx -> ReqCtx)
-> Maybe (Text, Requirements)
-> ReqCtx
-> ReqCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ReqCtx -> ReqCtx
forall a. a -> a
id
        ((Text -> Requirements -> ReqCtx -> ReqCtx)
-> (Text, Requirements) -> ReqCtx -> ReqCtx
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Requirements -> ReqCtx -> ReqCtx
forall t. Text -> t -> Ctx t -> Ctx t
Ctx.addBinding)
        ((,) (Text -> Requirements -> (Text, Requirements))
-> (LocVar -> Text)
-> LocVar
-> Requirements
-> (Text, Requirements)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocVar -> Text
lvVar (LocVar -> Requirements -> (Text, Requirements))
-> Maybe LocVar -> Maybe (Requirements -> (Text, Requirements))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe LocVar
mx Maybe (Requirements -> (Text, Requirements))
-> Maybe Requirements -> Maybe (Text, Requirements)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Requirements
mreq)
        (Syntax' ty -> ReqCtx
forall ty. Syntax' ty -> ReqCtx
extractReqCtx Syntax' ty
c1 ReqCtx -> ReqCtx -> ReqCtx
forall a. Semigroup a => a -> a -> a
<> Syntax' ty -> ReqCtx
forall ty. Syntax' ty -> ReqCtx
extractReqCtx Syntax' ty
c2)
    SAnnotate Syntax' ty
t1 Polytype
_ -> Syntax' ty -> ReqCtx
forall ty. Syntax' ty -> ReqCtx
extractReqCtx Syntax' ty
t1
    Term' ty
_ -> ReqCtx
forall a. Monoid a => a
mempty