{-

  This file generates Control/Monad/MultiLift.hs and
  Control/Monad/MultiWrap.hs.  To use, run:

  runhaskell multigen/multigen.hs

  from the top directory.

-}

module Main where

import Data.List
import System.IO
import System.FilePath

n = 9

subst _ [] _             = error "subst: empty name"
subst [] _ _             = []
subst str@(h:t) name val = 
    case stripPrefix name str of
      Nothing -> h : subst t name val
      Just t' -> val ++ subst t' name val

tgen 0 m = m
tgen n m = "(t" ++ show n ++ " " ++ tgen (n-1) m ++ ")"

multilift_class = do
  head <- readFile ("multigen" </> "MultiLift-head.hs")
  return $ subst head "@N@" (show n)

multiliftgen n = "instance (" ++ context n ++ ") => MultiLift "
                 ++ "m " ++ tgen n "m" ++ " where\n"
                 ++ "    mlift = "
                 ++ concat (intersperse " . " (replicate n "lift"))
                 ++ "\n\n"
    where
      context 0 = "Monad m"
      context n = "MonadTrans t" ++ show n ++ ", Monad " ++ tgen n "m"
                  ++ ", " ++ context (n-1)

multiwrap_class = do
  head <- readFile ("multigen" </> "MultiWrap-head.hs")
  return $ subst head "@N@" (show n)

multiwrapgen n = "instance (" ++ context n ++ ") => MultiWrap m "
                 ++ tgen n "m" ++ " a" ++ show n ++ " a0 where\n"
                 ++ "    mwrap = "
                 ++ concat (intersperse " . " (replicate n "wrap")) ++ "\n"
                 ++ fgen
                 ++ "\n"
    where
      fline i = "f" ++ show i ++ " <- "
                ++ concat (intersperse " $ " (replicate (n - i) "lift"))
                ++ (if i < n then " " else "") ++ "resultF\n"
      fgen = "    mresultF _ = do "
             ++ concat (intersperse "                    "
                        [fline j | j <- [1..n]])
             ++ "                    return $ "
             ++ concat (intersperse " . "
                        [("f" ++ show j) | j <- [1..n]])
             ++ "\n"

      context 0 = "Monad m"
      context n = "MonadTrans t" ++ show n
                  ++ ", Monad " ++ tgen n "m"
                  ++ ", MonadWrap t" ++ show n
                         ++ " a" ++ show n ++ " a" ++ show (n-1)
                  ++ ", " ++ context (n-1)

multilift h = do
  head <- multilift_class
  hPutStr h $ head ++ concat [multiliftgen x | x <- [1..n]]

multiwrap h = do
  head <- multiwrap_class
  hPutStr h $ head ++ concat [multiwrapgen x | x <- [1..n]]


main = do
  h1 <- openFile ("Control" </> "Monad" </> "MultiLift.hs") WriteMode
  multilift h1
  hClose h1
  h2 <- openFile ("Control" </> "Monad" </> "MultiWrap.hs") WriteMode
  multiwrap h2
  hClose h2