MonadLab-0.0.2: MLabCompileStub.hs

{-# LANGUAGE TemplateHaskell #-}

module Main where

import System
import IO
import Data.List
import Data.Maybe
import Language.Haskell.TH
import MonadLab.CommonTypes
import MonadLab.MonadLab
import MonadLab.MLabParser

$(do
	specFileName      <- runIO $ getEnv "MLAB_FILENAME"
	let moduleName     = takeWhile (/= '.') specFileName
	let moduleFileName = moduleName ++ ".hs"

	-- FIXME: Begin duct tape
	-- TH's pretty-printer inserts some spurious qualifiers into its output, so
	-- we drop them here. I'm not sure I'm getting everything here, though!
        let dropAll :: String -> String -> String
            dropAll _ []         = []
            dropAll p s@(c:rest) = if p `isPrefixOf` s then
                                      let s' = drop (length p) s in dropAll p s'
                                   else
                                      c:(dropAll p rest)

        let munge = (dropAll "GHC.Base.") . (dropAll "GHC.List.") . (dropAll "GHC.Err.") . (dropAll "GHC.Unit.")
        -- FIXME: End duct tape

        let lines :: String -> [String]
            lines ('\n':cs) = lines cs
            lines []        = []
            lines cs        = let
                                 (line,rest) = span (/= '\n') cs
                              in
                                 line : lines rest

	specFileContents  <- runIO $ readFile specFileName
        let specFileLines  = lines specFileContents
	let monadDecls     = mapMaybe (\ line -> if "monad " `isPrefixOf` line then Just (mlabParser line) else Nothing) specFileLines
	let regularDecls   = concat $ intersperse "\n" $ filter (not . ("monad " `isPrefixOf`)) specFileLines

	monadDecs         <- mapM (uncurry mkMonad) monadDecls
	let monadDecls     = (munge . pprint) monadDecs

	runIO $ writeFile moduleFileName ("module " ++ moduleName ++ " where\n\n")
	runIO $ appendFile moduleFileName ("import qualified Data.Monoid\nimport qualified Data.Tuple\nimport qualified Data.Either\n")
	runIO $ appendFile moduleFileName "--\n-- Regular declarations\n--\n\n"
	runIO $ appendFile moduleFileName (regularDecls ++ "\n\n\n")
	runIO $ appendFile moduleFileName "--\n-- Monad declarations\n--\n\n"
	runIO $ appendFile moduleFileName (monadDecls ++ "\n")	

	runIO $ putStrLn ("Generated " ++ moduleFileName)

	return [])

main :: IO ()
main = return ()