gistfile1.txt

module SnapApp.Processing (sanatizeSourceString) where
    
import GHC
import Outputable
import HsDecls

import Data.List
import Data.Maybe
import Control.Monad (unless)
import Text.Regex.Posix
import System.Environment
import System.Directory
import System.FilePath

import GHC.Paths ( libdir )
--GHC.Paths is available via cabal install ghc-paths
 
import DynFlags


isIrrelavent :: [String] -> Bool
isIrrelavent tag@(h:_) =
    (not $ h   `elem` ["GHC", "System", "Main"]) &&
    (not $ tag `elem` [["Control", "Monad", ">>="]
                      ,["Control", "Monad", "=<<"]])
isIrrelavent _ = False

functionRegex :: String
functionRegex = "^[A-Z][^.]*([.][A-Z][^.]*)*[.].+"

getFunctionMap :: String -> [String]
getFunctionMap inp =
    getAllTextMatches $ inp =~ funcMapExpression :: [String]
    where
        funcMapExpression = "([^.]+)"

getUsedFunctions :: String -> [[String]]
getUsedFunctions inp =
    filter isIrrelavent (map getFunctionMap fullFuncs)
    where
        fullFuncExpression = "([^[:space:]({[]*[.][^[:space:]);}]*)"
        fullFuncs = getAllTextMatches $ inp =~ fullFuncExpression :: [String]

parseFirstLine :: String -> [[String]]
parseFirstLine firstLine =
    map getFunctionMap unproc
    where unproc = (getAllTextMatches $ firstLine =~ "[^(--+.*tags=)]([^,]+)*" :: [String])

runOnFileName :: String -> IO ([[String]])
runOnFileName inp = do
   res <- sanatizeSource inp
   case res of
       Just (code, _, _, _)    -> return $ nub (getUsedFunctions $ showSDoc (ppr code))
       Nothing                 -> return [[]]

sanatizeSourceString :: String -> String -> IO ([[String]])
sanatizeSourceString fn contents = do
  tmpdir <- getTemporaryDirectory
  let tmp = tmpdir </> fn ++ ".hs"
  exists <- doesFileExist tmp
  unless exists $ writeFile tmp $ contents
  runOnFileName tmp

sanatizeSource :: String -> IO (Maybe RenamedSource)
sanatizeSource inp = defaultErrorHandler defaultLogAction $ do 
      runGhc (Just libdir) $ do
        dflags <- getSessionDynFlags
        let dflags' = foldl xopt_set dflags
                            [Opt_Cpp, Opt_ImplicitPrelude, Opt_MagicHash]
        setSessionDynFlags dflags
        target <- guessTarget inp Nothing
        setTargets [target]
        load LoadAllTargets
        modSum <- getModSummary $ mkModuleName "Main"
        p <- parseModule modSum
        t <- typecheckModule p
        d <- desugarModule t
        return $ renamedSource d