<commit_before>{-# language TemplateHaskellQuotes #-}
module Render.Command
  where

import           Relude                  hiding ( Reader
                                                , ask
                                                , lift
                                                )
import           Data.Text.Prettyprint.Doc
import           Language.Haskell.TH.Syntax
import           Polysemy
import           Polysemy.Reader
import qualified Data.Vector                   as V

import           Spec.Parse
import           Haskell                       as H
import           Marshal
import           Marshal.Scheme
import           Error
import           CType as C
import           Render.Element
import           Render.Type
import           Render.Scheme

renderCommand
  :: (HasErr r, Member (Reader RenderParams) r)
  => MarshaledCommand
  -> Sem r RenderElement
renderCommand m@MarshaledCommand {..} = contextShow mcName $ do
  RenderParams {..} <- ask
  genRe ("command " <> mcName) $ do
    let n = mkFunName mcName
    tellExport (ETerm n)
    nts <- V.mapMaybe id <$> traverseV (paramType schemeType) mcParams
    r <- makeReturnType m
    let t = foldr (~>) r nts
    tString <- renderType t
    tellDoc
      $  (pretty n <+> "::" <+> indent 0 tString)
      <> hardline
      <> (pretty n <+> "=" <+> "undefined")

paramType
  :: (HasErr r, Member (Reader RenderParams) r)
  => (MarshalScheme Parameter -> Sem r (Maybe H.Type))
  -> MarshaledParam
  -> Sem r (Maybe H.Type)
paramType st MarshaledParam {..} = contextShow (pName mpParam) $ do
  RenderParams {..} <- ask
  let Parameter {..} = mpParam
  n <- st mpScheme
  pure $ namedTy (mkParamName pName) <$> n

makeReturnType
  :: (HasErr r, HasRenderParams r) => MarshaledCommand -> Sem r H.Type
makeReturnType MarshaledCommand {..} = do
  pts <- V.mapMaybe id <$> traverseV (paramType schemeTypePositive) mcParams
  r   <- case mcReturn of
    C.Void -> pure V.empty
    r      -> V.singleton <$> cToHsType DoNotPreserve r
  let ts = pts <> r
  pure $ ConT ''IO :@ foldl' (:@) (TupleT (length ts)) ts
<commit_msg>stub for marshaled commands<commit_after>{-# language TemplateHaskellQuotes #-}
module Render.Command
  where

import           Relude                  hiding ( Reader
                                                , ask
                                                , lift
                                                )
import           Data.Text.Prettyprint.Doc
import           Data.Text.Extra                ( upperCaseFirst )
import           Language.Haskell.TH.Syntax
import           Polysemy
import           Polysemy.Reader
import qualified Data.Vector                   as V

import           Foreign.Ptr

import           Spec.Parse
import           Haskell                       as H
import           Marshal
import           Marshal.Scheme
import           Error
import           CType                         as C
import           Render.Element
import           Render.Type
import           Render.Scheme
import           Render.SpecInfo
import           Render.Poke

renderCommand
  :: (HasErr r, Member (Reader RenderParams) r, HasSpecInfo r)
  => MarshaledCommand
  -> Sem r RenderElement
renderCommand m@MarshaledCommand {..} = contextShow mcName $ do
  RenderParams {..} <- ask
  let Command {..} = mcCommand
  genRe ("command " <> mcName) $ do
    ffiTy <- cToHsType
      DoPreserve
      (Proto cReturnType
             [ (Nothing, pType) | Parameter {..} <- toList cParameters ]
      )
    dynamicBindType <- renderType $ ConT ''FunPtr :@ ffiTy ~> ffiTy
    let dynName = "mk" <> upperCaseFirst cName
    marshaledCommandCall dynName m
    tellDoc $ vsep
      [ mempty
      , "foreign import ccall"
      , "#if !defined(SAFE_FOREIGN_CALLS)"
      , indent 2 "unsafe"
      , "#endif"
      , indent 2 "\"dynamic\"" <+> pretty dynName
      , indent 2 ("::" <+> dynamicBindType)
      ]

paramType
  :: (HasErr r, Member (Reader RenderParams) r)
  => (MarshalScheme Parameter -> Sem r (Maybe H.Type))
  -> MarshaledParam
  -> Sem r (Maybe H.Type)
paramType st MarshaledParam {..} = contextShow (pName mpParam) $ do
  RenderParams {..} <- ask
  let Parameter {..} = mpParam
  n <- st mpScheme
  pure $ namedTy (mkParamName pName) <$> n

makeReturnType
  :: (HasErr r, HasRenderParams r) => MarshaledCommand -> Sem r H.Type
makeReturnType MarshaledCommand {..} = do
  pts <- V.mapMaybe id <$> traverseV (paramType schemeTypePositive) mcParams
  r   <- case mcReturn of
    C.Void -> pure V.empty
    r      -> V.singleton <$> cToHsType DoNotPreserve r
  let ts = pts <> r
  pure $ ConT ''IO :@ foldl' (:@) (TupleT (length ts)) ts

----------------------------------------------------------------
-- Calling this command
----------------------------------------------------------------

marshaledCommandCall
  :: (HasErr r, HasSpecInfo r, HasRenderParams r, HasRenderElem r)
  => Text
  -> MarshaledCommand
  -> Sem r ()
marshaledCommandCall dynName m@MarshaledCommand {..} = do
  RenderParams {..} <- ask
  let n = mkFunName mcName
  tellExport (ETerm n)
  nts <- V.mapMaybe id <$> traverseV (paramType schemeType) mcParams
  r   <- makeReturnType m
  let t = foldr (~>) r nts
  tDoc  <- renderType t
  pokes <- forV mcParams
    $ \MarshaledParam {..} -> pure $ pretty (pName mpParam) <+> "<- undefined"
  let call = pretty dynName <+> parens "error \"Fun Ptr\"" <+> sep
        (pretty . pName . mpParam <$> toList mcParams)
  tellDoc
    . vsep
    $ [ pretty n <+> "::" <+> indent 0 tDoc
      , pretty n <+> "=" <+> doBlock (toList pokes <> [call])
      ]
{'fraction_non_alphanumeric': 0.12511170688114387, 'fraction_numerical': 0.0008936550491510277, 'mean_word_length': 1.7744174516608826, 'pattern_counts': {'":': 3, '<': 55, '<?xml version=': 0, '>': 60, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 12, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1667294', 'n_tokens_mistral': 1687, 'n_tokens_neox': 1618, 'n_words': 479}