freesect-0.8: Main.hs

--     Package:  freesect-0.8
-- Description:  Extend Haskell to support free sections
--     Example:  zipWith (f __ b __ d) as cs
--      Author:  Andrew Seniuk <rasfar@gmail.com>
--        Date:  March 11, 2012
--     License:  BSD3 (./LICENSE)
--  Executable:  freesect
--       Usage:  See accompanying files 000-readme and z

{-# LANGUAGE CPP #-}
{- # LANGUAGE NoMonomorphismRestriction #-}  -- helpful for certain debugging

-- CPP definitions are now set using compiler options; see ./z and ./ile.
--  #define ANNOTATED 0
--  #define PARALLEL 0
--  #define GHC_F 1
--  #define DEBUG 0
--  #define CLEAN_EXTRANEOUS_GROUPINGS 0

-- Most helpful sources:
--  - http://hpaste.org/steps/10722  -- use of everywhereM with State
--  - #haskell (thanks dreixel, ski, dolio, quintessence, ...)

  module Main(main) where

  import System.Environment(getArgs)
  import System.IO(writeFile,hFlush,stdout)

#if PARALLEL
  import Control.Parallel.Strategies(rpar,parTraversable,runEval)
#endif

-- We must use a local, patched version of the haskell-src-exts package,
-- which is renamed "HSE" to avoid possible confusion.
#if ANNOTATED
  import HSE.Annotated
--import Language.Haskell.Exts.Annotated
#else
  import HSE
--import Language.Haskell.Exts
#endif

  import FilesAndParsing
  import Util
#if ANNOTATED
  import FreeSectAnnotated
#else
  import FreeSect
#endif

--------------------------------------------------------------------------------

  main :: IO ()
  main
   = do (outfile:lexsrc_pathnames) <- getArgs
        lexsrc_serials_ <- mapM readSourcesFromFileOrDir lexsrc_pathnames
        let
          (pnames,lexsrc_serials) = unzip $ concat $ reverse lexsrc_serials_
#if ANNOTATED
#if PARALLEL
          parsedsrc_maybes
           = (runEval $ parTraversable rpar
                      $ doParsing pnames lexsrc_serials)
                          :: [ParseResult (Module SrcSpanInfo)]
#else
          parsedsrc_maybes
           = (doParsing pnames lexsrc_serials)
                :: [ParseResult (Module SrcSpanInfo)]
#endif
#else
          parsedsrc_maybes
           = (doParsing pnames lexsrc_serials) :: [ParseResult Module]
#endif
        let
--        parsed_srcs = error $ ( ( concatMap prettyPrint $ ( ( testParses parsedsrc_maybes ) :: [Module] ) ) :: String )
#if ANNOTATED
          parsed_srcs = ( testParses parsedsrc_maybes ) :: [Module SrcSpanInfo]
#else
          parsed_srcs = ( testParses parsedsrc_maybes ) :: [Module]
#endif
#if 0
        let
          test = ( error $ show $ map fs_FSW_lineal_chains parsed_srcs ) :: String
        print test
#endif
        let
#if 0
          -- for debugging, we sometimes like to bypass the transformation
          transformed_srcs = parsed_srcs
#else
#if ANNOTATED
#if PARALLEL
          transformed_srcs = ( runEval $ parTraversable rpar $ 
                               map fs_module parsed_srcs
                               ) :: [Module SrcSpanInfo]
#else
          transformed_srcs = ( map fs_module parsed_srcs
                               ) :: [Module SrcSpanInfo]
#endif
#else
#if PARALLEL
          transformed_srcs = ( runEval $ parTraversable rpar $ 
                               map fs_module parsed_srcs
                               ) :: [Module]
#else
          transformed_srcs = ( map fs_module parsed_srcs
                               ) :: [Module]
#endif
#endif
#endif

        let
          transformed_srcs' = map stripFSPragma transformed_srcs
          transformed_srcs'' = map stripEmptyPragmaList transformed_srcs'
#if GHC_F
#else
          transformed_srcs''' = map (fixModuleName outfile) transformed_srcs''
#endif

#if GHC_F
        debug parsed_srcs transformed_srcs''
        writeFile outfile $ concatMap prettyPrint transformed_srcs''
#else
        debug parsed_srcs transformed_srcs'''
        writeFile (outfile++".hs") $ concatMap prettyPrint transformed_srcs'''
#endif

        hFlush stdout

--------------------------------------------------------------------------------

#if 0
-- actually unnecessary (and this comment can't go on the #if 0 line...)
#if ANNOTATED
  debug :: [Module SrcSpanInfo] -> [Module SrcSpanInfo] -> IO ()
#else
  debug :: [Module] -> [Module] -> IO ()
#endif
#endif
  debug ms ms'
   = do
#if DEBUG
#if 0
        -- one-liner AST tree dump (before-and-after)
        putStrLn $ show ms
        putStrLn $ show ms'
#endif
#if 1
        -- pretty-printed lexical sourcecode (before-and-after)
        putStrLn $ concatMap prettyPrint ms
        putStrLn $ concatMap prettyPrint ms'
#endif
#endif
        return ()