Convert.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}

module PureNix.Convert (convert, ModuleInfo (..)) where

import Data.Bitraversable
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Text.Internal.Search (indices)
import Language.PureScript (Ident (..))
import qualified Language.PureScript as P
import Language.PureScript.CoreFn
import Language.PureScript.Errors (SourceSpan)
import Language.PureScript.PSString (PSString (toUTF16CodeUnits))
import qualified PureNix.Expr as N
import qualified PureNix.Identifiers as N
import PureNix.Prelude

-- | The monad conversion runs in.
-- Conversion is per-module, which means that only the SourceSpan part of the ReaderT ever changes during conversion.
-- The StateT actually fuffills the role of a CPS'd WriterT.
type Convert = ReaderT (FilePath, P.ModuleName, SourceSpan) (State ModuleInfo)

-- | Represents the information collected about a module during conversion.
-- It is intended to be used in a WriterT-style fashion, which is why it has a 'Monoid' instance.
data ModuleInfo = ModuleInfo
  { -- | Whether the module has any FFI declarations.
    -- In the 'Monoid' instance, this behaves like an 'Data.Monoid.Any'.
    usesFFI :: Bool,
    -- | Locations of strings that appear to perform string interpolation.
    interpolatedStrings :: Set SourceSpan
  }
  deriving (Eq, Show)

instance Semigroup ModuleInfo where ModuleInfo fa ia <> ModuleInfo fb ib = ModuleInfo (fa || fb) (ia <> ib)

instance Monoid ModuleInfo where mempty = ModuleInfo False mempty

tell :: ModuleInfo -> Convert ()
tell m = modify (mappend m)

-- | The central PureScript-to-Nix conversion function for a single PureScript module.
convert :: Module Ann -> (N.Expr, ModuleInfo)
convert (Module spn _comments name path imports exports reexports foreign' decls) =
  flip runState mempty $
    flip runReaderT (path, name, spn) $
      module' name imports exports reexports foreign' decls

localSpan :: SourceSpan -> Convert a -> Convert a
localSpan spn = local (fmap $ const spn)

localAnn :: Ann -> Convert a -> Convert a
localAnn (spn, _, _, _) = localSpan spn

{-# ANN module' ("hlint: ignore Use list comprehension" :: String) #-}
module' ::
  P.ModuleName ->
  [(Ann, P.ModuleName)] ->
  [Ident] ->
  Map P.ModuleName [Ident] ->
  [Ident] ->
  [Bind Ann] ->
  Convert N.Expr
module' thisModule imports exports reexports foreign' decls = do
  let importBinding =
        let attrs =
              [ (N.moduleKey mdl, N.app (N.var "import") (N.path ("../" <> P.runModuleName mdl)))
                | (_, mdl) <- imports,
                  mdl /= thisModule,
                  mdl /= P.ModuleName "Prim"
              ]
         in ("module", N.attrs [] [] attrs)
      ffiBinds = foreignBinding <$> foreign'
      expts = N.mkVar <$> exports
      reexpts = uncurry inheritFrom <$> M.toList reexports
  ffiFileBinding <-
    if null foreign'
      then pure []
      else [("foreign", N.app (N.var "import") (N.path "./foreign.nix"))] <$ tell mempty {usesFFI = True}
  binds <- bindings decls
  pure $
    N.let'
      (importBinding : ffiFileBinding <> ffiBinds <> binds)
      (N.attrs expts reexpts mempty)
  where
    inheritFrom :: P.ModuleName -> [Ident] -> (N.Expr, [N.Key])
    inheritFrom m exps = (N.sel (N.var "module") (N.moduleKey m), N.identKey <$> exps)

    foreignBinding :: Ident -> (N.Var, N.Expr)
    foreignBinding ffiIdent = (N.mkVar ffiIdent, N.sel (N.var "foreign") (N.identKey ffiIdent))

bindings :: [Bind Ann] -> Convert [(N.Var, N.Expr)]
bindings = traverse binding . (>>= flatten)
  where
    binding :: (Ann, Ident, Expr Ann) -> Convert (N.Var, N.Expr)
    binding (ann, i, e) = localAnn ann $ fmap (N.mkVar i,) (expr e)
    flatten :: Bind a -> [(a, Ident, Expr a)]
    flatten (NonRec a i e) = [(a, i, e)]
    flatten (Rec bs) = (\((a, i), e) -> (a, i, e)) <$> bs

expr :: Expr Ann -> Convert N.Expr
expr (Abs ann arg body) = localAnn ann $ fmap (N.lam (N.mkVar arg)) (expr body)
expr (Literal ann lit) = localAnn ann $ literal lit
-- Newtype wrappers can always be removed.
expr (App ann (Var (_, _, _, Just IsNewtype) _) x) = localAnn ann (expr x)
expr (App ann f x) = localAnn ann $ liftA2 N.app (expr f) (expr x)
expr (Var ann (P.Qualified mqual name)) = localAnn ann $ do
  (_, thisModule, _) <- ask
  pure $ case mqual of
    Just qual
      | qual /= thisModule -> N.sel (N.sel (N.var "module") (N.moduleKey qual)) (N.identKey name)
    _ -> N.var (N.mkVar name)
expr (Accessor ann sel body) = localAnn ann $ flip N.sel (N.stringKey sel) <$> expr body
expr (Let ann binds body) = localAnn ann $ liftA2 N.let' (bindings binds) (expr body)
expr (ObjectUpdate ann a b) = localAnn ann $ liftA2 (N.bin N.Update) (expr a) (attrs b)
expr (Constructor _ _ (P.ProperName dataName) fields) = pure $ N.constructor dataName (N.mkVar <$> fields)
expr (Case ann exprs cases) =
  localAnn ann $ do
    exprs' <- traverse expr exprs
    cases' <- traverse (alternative exprs') cases
    (fp, _, spn) <- ask
    let patternCases = zip (N.numberedVars "__pattern") cases'
        patternFail =
          ( "__patternFail",
            N.app
              (N.builtin "throw")
              (N.string $ T.concat ["Pattern match failure in ", T.pack fp, " at ", P.displayStartEndPosShort spn])
          )
        patterns = patternCases <> [patternFail]
    pure $
      N.let'
        patterns
        (foldr1 N.app (N.var . fst <$> patterns))

-- | Generates a matcher for a given case alternative, against the given list of scrutinees.
-- A matcher takes a failure continuation, and either calls the expression body with the matched names in scope, or if the matcher fails, the failure continutation.
alternative :: [N.Expr] -> CaseAlternative Ann -> Convert N.Expr
alternative scrutinees = go
  where
    go (CaseAlternative binders body) = do
      (patternChecks, patternBinds) <- zipBinders scrutinees binders
      body' <- unguard body (N.var "__fail")
      pure $
        N.lam "__fail" $
          case patternChecks of
            [] -> N.let' patternBinds body'
            _ ->
              N.cond
                (foldr1 (N.bin N.And) patternChecks)
                (N.let' patternBinds body')
                (N.var "__fail")

-- | Generates a matcher (see 'alternative') for a potentially guarded 'CaseAlternative' body.
-- For guards, we test every guard in order with the failure continuation as the final case.
unguard :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> N.Expr -> Convert N.Expr
unguard (Right body) _ = expr body
unguard (Left guardedBodies) failCase = do
  guardedBodies' <- traverse (bitraverse expr expr) guardedBodies
  pure $ foldr (uncurry N.cond) failCase guardedBodies'

zipBinders :: [N.Expr] -> [Binder Ann] -> Convert ([N.Expr], [(N.Var, N.Expr)])
zipBinders exprs binds = mconcat <$> zipWithM unbinder binds exprs

-- | Turns a binder(/pattern) and a scrutinee into a pair of
--   - boolean expressions, that all return true iff the pattern applies
--   - the bindings produced by the pattern
unbinder :: Binder Ann -> N.Expr -> Convert ([N.Expr], [(N.Var, N.Expr)])
unbinder (NullBinder _) _ = pure mempty
unbinder (VarBinder _ name) scrut = pure $ (\name' -> ([], [(name', scrut)])) $ N.mkVar name
unbinder (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [field]) scrut = unbinder field scrut
unbinder (ConstructorBinder ann _ (P.Qualified _ (P.ProperName tag)) fields) scrut =
  localAnn ann $
    mappend ([N.bin N.Equals (N.sel scrut "__tag") (N.string tag)], []) . mconcat <$> zipWithM (\binder field -> unbinder binder (N.sel scrut field)) fields (N.numberedKeys "__field")
unbinder (NamedBinder ann name binder) scrut = localAnn ann $ do
  mappend ([], [(N.mkVar name, scrut)]) <$> unbinder binder scrut
unbinder (LiteralBinder ann lit) scrut' = localAnn ann $ litBinder lit scrut'
  where
    litBinder :: Literal (Binder Ann) -> N.Expr -> Convert ([N.Expr], [(N.Var, N.Expr)])
    litBinder (NumericLiteral (Left n)) scrut = pure ([N.bin N.Equals scrut (N.int n)], [])
    litBinder (NumericLiteral (Right x)) scrut = pure ([N.bin N.Equals scrut (N.double x)], [])
    litBinder (StringLiteral str) scrut = (\str' -> ([N.bin N.Equals scrut (N.string str')], [])) <$> string str
    litBinder (CharLiteral char) scrut = pure ([N.bin N.Equals scrut (N.string (T.singleton char))], [])
    litBinder (BooleanLiteral True) scrut = pure ([scrut], [])
    litBinder (BooleanLiteral False) scrut = pure ([N.not' scrut], [])
    litBinder (ArrayLiteral as) scrut =
      mappend ([N.bin N.Equals (N.app (N.builtin "length") scrut) (N.int (fromIntegral n))], []) . mconcat
        <$> zipWithM (\binder ix -> unbinder binder (elemAt scrut ix)) as [0 :: Integer ..]
      where
        n = length as
        elemAt list ix = N.app (N.app (N.builtin "elemAt") list) (N.int ix)
    litBinder (ObjectLiteral fields) scrut = mconcat <$> traverse (\(field, binder) -> unbinder binder (N.sel scrut (N.stringKey field))) fields

attrs :: [(PSString, Expr Ann)] -> Convert N.Expr
attrs = fmap (N.attrs [] []) . traverse attr
  where
    attr (string, body) = (N.stringKey string,) <$> expr body

string :: PSString -> Convert Text
string str = do
  let decoded = T.pack . map (toEnum . fromIntegral) . toUTF16CodeUnits $ str
  when (mightContainInterpolation decoded) $ do
    (_, _, spn) <- ask
    tell mempty {interpolatedStrings = S.singleton spn}
  pure decoded
  where
    -- Performs a _very_ rudimentary check for interpolation:
    -- Simply checks if "${" occurs in the string, and if so, there's a "}" occurring later in the string.
    -- This does not account for any possible escaping/quoting.
    mightContainInterpolation :: Text -> Bool
    mightContainInterpolation t = case indices "${" t of
      [] -> False
      (ixOpen : _) -> any (> ixOpen) $ indices "}" t

literal :: Literal (Expr Ann) -> Convert N.Expr
literal (NumericLiteral (Left n)) = pure $ N.int n
literal (NumericLiteral (Right n)) = pure $ N.double n
literal (StringLiteral str) = N.string <$> string str
literal (CharLiteral chr) = pure $ N.string $ T.singleton chr
literal (BooleanLiteral b) = pure $ bool (N.var "false") (N.var "true") b
literal (ArrayLiteral arr) = N.list <$> traverse expr arr
literal (ObjectLiteral obj) = attrs obj