Generate mkFnX/runFnX FFI

Main.purs

module Main where

import Prelude

import Data.Array as Array
import Data.Foldable as F
import Data.Traversable as T
import Effect (Effect)
import Effect.Class.Console (log)
import TryPureScript as TryPureScript
import Dodo as D
import Data.Monoid (power)

main :: Effect Unit
main = TryPureScript.render =<< TryPureScript.withConsole do
  let fns = buildFunctions
  log $ D.print D.plainText D.twoSpaces $ 
    F.fold
      [ (F.intercalate (D.break <> D.break) fns.mkFnX)
      , (D.break <> D.break)
      , (F.intercalate (D.break <> D.break) fns.runFnX)
      ]

buildFunctions
  :: { mkFnX :: Array (D.Doc Void)
     , runFnX :: Array (D.Doc Void)
     }
buildFunctions = 
  { mkFnX: map _.mkFnX intermediateResult
  , runFnX: map _.runFnX intermediateResult
  }
  where
  args = ["a", "b", "c", "d", "e", "f", "g", "h", "i", "j"]
  intermediateResult = _.value $ T.mapAccumL accumFn [] args
  accumFn
    :: Array String
    -> String 
    -> { accum :: Array String
       , value :: 
          { mkFnX :: D.Doc Void
          , runFnX :: D.Doc Void
          }
       }
  accumFn arraySoFar nextArg = do
    let newAccum = Array.snoc arraySoFar nextArg
    { accum: newAccum
    , value: 
        { mkFnX: mkFnX newAccum
        , runFnX: runFnX newAccum
        }
    }

mkFnX :: Array String -> D.Doc Void
mkFnX args =
  D.lines
    [ D.text $ "(scm:define mkFn" <> show argLength
    , D.indent $ D.lines 
        [ D.text "(scm:lambda (fn)"
        , D.indent $ rest \idents -> do
            let
              result = idents # flip F.foldr { init: true, doc: mempty } \next dAcc  ->
                { init: false
                , doc: if dAcc.init then
                    D.text $ "(fn " <> next <> ")"
                    else
                      D.words [ D.text "(" <> dAcc.doc, D.text $ next <> ")" ]
                }
            result.doc <> (D.text $ power ")" (2 + Array.length idents))
        ]
    ]
  where
  argLength = Array.length args
  rest :: (Array String -> D.Doc Void) -> D.Doc Void
  rest cb = (F.foldr foldFn cb args) []
    where
    foldFn next acc idents = do
      D.lines
        [ D.text $ "(scm:lambda (" <> next <> ")"
        , D.indent $ acc $ Array.cons next idents
        ]

runFnX :: Array String -> D.Doc Void
runFnX args = 
  D.lines
    [ D.text $ "(scm:define runFn" <> show (Array.length args)
    , D.indent $ D.lines 
        [ D.text "(scm:lambda (fn)"
        , D.indent $ D.lines
            [ D.text "(scm:lambda (" <> (D.words $ map D.text args) <> D.text ")"
            , D.indent do
                let
                  result = args # flip F.foldl { init: true, doc: mempty } \dAcc next ->
                    { init: false
                    , doc: if dAcc.init then
                          D.words [ D.text $ "(fn", D.text $ next <> ")" ]
                        else
                          D.words [ D.text "(" <> dAcc.doc, D.text $ next <> ")" ]
                    }
                result.doc <> D.text ")))"
            ]
        ]
    ]