diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2008 Marco Túlio Gontijo e Silva + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,326 @@ +module Main where + +import Prelude hiding (catch) +import Control.Applicative +import Control.Exception +import Control.Monad.Error.Class +import Control.Monad.Reader +import Control.Monad.Trans +import Data.List +import Data.Maybe +import Language.Haskell.Interpreter.GHC +import Language.Haskell.Parser +import Language.Haskell.Syntax +import System.Directory +import System.Environment + +type InterleavableReader a = Reader (String, [String]) a +type InterleavableReaderT a = ReaderT (String, [String]) IO a +type TypeToDefinition = Reader (String, String, HsType) String + +addTypes :: InterleavableReaderT String +addTypes + = do + reader <- ask + liftIO + $ do + session <- newSession + unlines <$> zipWith (flip (++)) (runReader newFunctionsWithoutType reader) <$> withSession session + ( + catchInterpreterError + $ setUseLanguageExtensions True + >> loadModules [runReader fileName reader] + >> setTopLevelModules [runReader newModule reader] + >> mapM typeOfHaskell (runReader newFunctionNames reader) + ) + +argumentList :: Char -> Int -> String +argumentList char number = unwords_ (map ((char :) . show) $ tail [0 .. number]) + +arguments :: HsType -> [HsType] +arguments (HsTyFun type_ rest) = type_ : arguments rest +arguments _ = [] + +bug :: String +bug = "\nThis shouldn't happen. Please report the bug to marcot@riseup.net." + +catchInterpreterError :: Interpreter a -> Interpreter a +catchInterpreterError function = catchError function treatInterpreterError + +createModule :: InterleavableReader String -> InterleavableReaderT () +createModule code + = do + reader <- ask + liftIO + $ createDirectoryIfMissing True (runReader directoryName reader) + >> writeFile (runReader fileName reader) (runReader code reader) + +class Decls a where + getImports :: a -> [String] + isIO :: a -> Bool + +instance Decls HsDecl where + getImports (HsTypeSig _ _ (HsQualType context type_)) + = union (foldr union [] $ map (getImports . fst) context) $ getImports type_ + getImports _ = error $ "getImports (_ :: HsDecl)." ++ bug + + isIO (HsTypeSig _ _ (HsQualType _ type_)) = isIO type_ + isIO _ = error $ "isIO (_ :: HsDecl)." ++ bug + +instance Decls HsType where + getImports (HsTyFun type_ rest) = union (getImports type_) (getImports rest) + getImports (HsTyTuple list) = foldr union [] $ map getImports list + getImports (HsTyApp type_ rest) = union (getImports type_) (getImports rest) + getImports (HsTyCon hsName) = getImports hsName + getImports _ = [] + + isIO (HsTyFun type_ rest) = isIO type_ || isIO rest + isIO (HsTyApp (HsTyCon hsName) _) = isIO hsName + isIO _ = False + +instance Decls HsQName where + getImports (Qual (Module module_) _) = [module_] + getImports _ = [] + + isIO (Qual _ (HsIdent "IO")) = True + isIO (UnQual (HsIdent "IO")) = True + isIO _ = False + +definitionBody :: TypeToDefinition +definitionBody + = do + suffix <- definitionSuffix + (_, _, type_) <- ask + case returnsFunction type_ of + Nothing + -> do + prefix <- definitionPrefix " " + return $ " =" ++ prefix ++ suffix + Just result + -> do + prefix <- definitionPrefix "\n " + return + $ "\n =" ++ prefix ++ "do\n function <- " ++ suffix + ++ "\n return " ++ treatArgument "liftIO" "function" result + +definitionPrefix :: String -> TypeToDefinition +definitionPrefix separator + = do + (_, _, type_) <- ask + return + $ " " + ++ (if needsInterleavable type_ then "embed $" ++ separator ++ "\\ buffer ->" else "liftIO" ++ separator ++ "$") + ++ " " + +definitionSuffix :: TypeToDefinition +definitionSuffix + = do + (module_, hsName, type_) <- ask + argumentNames <- getArgumentNames + return + $ module_ ++ "." ++ hsName + ++ if needsInterleavable type_ + then unwords_ $ zipWith (treatArgument "callback buffer") (words argumentNames) $ arguments type_ + else argumentNames + +directoryName :: InterleavableReader String +directoryName = reverse <$> dropWhile (/= '/') <$> reverse <$> slash + +draftBody :: InterleavableReader String +draftBody = unlines <$> newFunctionsWithoutType + +extraImports :: InterleavableReader [String] +extraImports = foldr union [] <$> map getImports <$> newFunctionOldDecls + +extraImportsWithPrelude :: InterleavableReader [String] +extraImportsWithPrelude = union ["Prelude"] <$> extraImports + +fileName :: InterleavableReader String +fileName = (++ ".hs") <$> slash + +getArgumentNames :: TypeToDefinition +getArgumentNames + = do + (_, _, type_) <- ask + return $ argumentList 'a' $ numArguments type_ + +getExports :: String -> IO [String] +getExports module_ + = do + session <- newSession + withSession session $ catchInterpreterError + $ setImports [module_] >> getModuleFunctions module_ >>= mapM typeOfHaskell + +getExtraImportsHaskell :: InterleavableReaderT String +getExtraImportsHaskell + = do + reader <- ask + liftIO + $ do + session <- newSession + unlines + <$> zipWith (\ import_ exports -> runReader (getImportHaskell import_ exports) reader) + (runReader extraImportsWithPrelude reader) + <$> withSession session + (catchInterpreterError $ mapM getModuleFunctions $ runReader extraImportsWithPrelude reader) + +getHeader :: InterleavableReader String +getHeader + = do + module_ <- asks fst + newModule_ <- newModule + newFunctionNames_ <- newFunctionNames + return + $ "{-# OPTIONS_GHC -fno-monomorphism-restriction #-}\n{-# LANGUAGE FlexibleContexts #-}\n" + ++ "-- This code was generated by interlavableGen. Comments: Marco Túlio Gontijo e Silva \n" + ++ "module " ++ newModule_ ++ parenthesisList (("module " ++ module_) : newFunctionNames_) ++ "\n where\n\n" + +getImportHaskell :: String -> [String] -> InterleavableReader String +getImportHaskell import_ exports + = do + importHidings_ <- importHidings exports + return $ "import " ++ import_ ++ if null importHidings_ then "" else " hiding" ++ parenthesisList importHidings_ + +getImportsHaskell :: String -> InterleavableReader String +getImportsHaskell extraImportsHaskell + = do + module_ <- asks fst + newFunctionNames_ <- newFunctionNames + return + $ "import Control.Monad.Trans\nimport Control.Monad.Trans.InterleavableIO\n" + ++ "import " ++ module_ ++ " hiding" ++ parenthesisList newFunctionNames_ ++ "\nimport qualified " ++ module_ ++ "\n" + ++ extraImportsHaskell + +getModuleFunctions :: String -> Interpreter [String] +getModuleFunctions module_ = catMaybes <$> map isFunction <$> getModuleExports module_ + +importHidings :: [String] -> InterleavableReader [String] +importHidings exports = intersect exports <$> union ["liftIO", "embed", "callback"] <$> newFunctionNames + +interleavableModule :: (Bool, String) -> IO () +interleavableModule parameters @ (_, module_) = catch (interleavable parameters) $ treatInterleavable module_ + +interleavable :: (Bool, String) -> IO () +interleavable (withType, module_) + = do + moduleExports <- getExports module_ + liftIO $ flip runReaderT (module_, moduleExports) + $ do + extraImportsHaskell <- getExtraImportsHaskell + createModule $ moduleCode extraImportsHaskell (runReader draftBody (module_, moduleExports)) + when withType $ moduleCode extraImportsHaskell <$> addTypes >>= createModule + +isFunction :: ModuleElem -> Maybe String +isFunction (Fun function) = Just function +isFunction _ = Nothing + +main :: IO () +main = getArgs >>= parseOptions + +moduleCode :: String -> String -> InterleavableReader String +moduleCode extraImportsHaskell body + = do + imports <- getImportsHaskell extraImportsHaskell + header <- getHeader + return $ header ++ imports ++ body + +nameWithType :: HsDecl -> (String, HsType) +nameWithType (HsTypeSig _ [(HsIdent hsName)] (HsQualType _ type_)) = (hsName, type_) +nameWithType _ = error $ "nameWithType _" ++ bug + +needsInterleavable :: HsType -> Bool +needsInterleavable (HsTyFun type_ rest) = isIO type_ || needsInterleavable rest +needsInterleavable _ = False + +newFunctionNames :: InterleavableReader [String] +newFunctionNames = map fst <$> newFunctionNamesWithOldTypes + +newFunctionNamesWithOldTypes :: InterleavableReader [(String, HsType)] +newFunctionNamesWithOldTypes = map nameWithType <$> newFunctionOldDecls + +newFunctionOldDecls :: InterleavableReader [HsDecl] +newFunctionOldDecls = filter isIO <$> parsedBody + +newFunctionsWithoutType :: InterleavableReader [String] +newFunctionsWithoutType = newFunctionNamesWithOldTypes >>= mapM typeToDefinition + +newModule :: InterleavableReader String +newModule = ("Control.Monad.Trans.InterleavableIO." ++) <$> asks fst + +numArguments :: HsType -> Int +numArguments = length . arguments + +parenthesisList :: [String] -> String +parenthesisList list = "\n ( " ++ intercalate "\n , " list ++ "\n )" + +parsedBody :: InterleavableReader [HsDecl] +parsedBody + = do + moduleExports <- asks snd + case parseModule $ unlines moduleExports of + ParseOk (HsModule _ _ _ _ parsed) -> return parsed + ParseFailed (SrcLoc _ line _) message + -> error + $ "parsed: " ++ moduleExports !! pred line ++ ": " ++ message ++ "." ++ bug + +parseOptions :: [String] -> IO () +parseOptions options + | elem "--no-type-signatures" options + = mapM_ interleavableModule $ map ((,) False) $ filter (/= "--no-type-signatures") options + | elem "--help" options || elem "-h" options || null options + = do + progName <- getProgName + putStrLn $ "Usage:\n " ++ progName ++ " [--no-type-signatures] ...\n " ++ progName ++ " -h|--help" + | otherwise = mapM_ interleavableModule $ map ((,) True) options + +replace :: Eq a => a -> a -> [a] -> [a] +replace from to = map (\ x -> if x == from then to else x) + +returnsFunction :: HsType -> Maybe HsType +returnsFunction (HsTyFun _ rest) = returnsFunction rest +returnsFunction (HsTyApp (HsTyCon (Qual _ (HsIdent "IO"))) result @ (HsTyFun _ _)) = Just result +returnsFunction _ = Nothing + +slash :: InterleavableReader String +slash = replace '.' '/' <$> newModule + +treatArgument :: String -> String -> HsType -> String +treatArgument caller argumentName argument + | isIO argument && numArguments argument > 0 + = "(\\" ++ (argumentList 'b' $ numArguments argument) ++ " -> " + ++ caller ++ " $ " ++ argumentName ++ " " ++ (argumentList 'b' $ numArguments argument) ++ ")" + | isIO argument = "(" ++ caller ++ " " ++ argumentName ++ ")" + | otherwise = argumentName + +treatInterleavable :: String -> Exception -> IO () +treatInterleavable module_ exception + = do + progName <- getProgName + putStrLn $ progName ++ ": Error: " ++ module_ ++ ": " ++ show exception + +treatInterpreterError :: InterpreterError -> Interpreter a +treatInterpreterError (UnknownError string)= error $ "InterpreterError.UnknownError: " ++ string +treatInterpreterError (WontCompile list) = error $ "InterpreterError.WontCompile: List of GHC Errors: " ++ show list +treatInterpreterError (NotAllowed string) = error $ "InterpreterError.NotAllowed: " ++ string +treatInterpreterError (GhcException exception) = error $ "InterpreterError.GhcException: " ++ show exception + +typeOfHaskell :: String -> Interpreter String +typeOfHaskell function + = do + type_ <- typeOf function + return $ "\n" ++ function ++ " :: " ++ (replace '\n' ' ' type_) + +typeToDefinition :: (String, HsType) -> InterleavableReader String +typeToDefinition (hsName, type_) + = do + module_ <- asks fst + return $ flip runReader (module_, hsName, type_) + $ do + argumentNames <- getArgumentNames + definition <- definitionBody + return $ '\n' : hsName ++ argumentNames ++ definition + +unwords_ :: [String] -> String +unwords_ [] = "" +unwords_ list = " " ++ unwords list + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/interleavableGen.cabal b/interleavableGen.cabal new file mode 100644 --- /dev/null +++ b/interleavableGen.cabal @@ -0,0 +1,19 @@ +name: interleavableGen +version: 0.0.1 +cabal-version: >= 1.2.3.0 +build-type: Simple +license: OtherLicense +license-file: LICENSE +copyright: (c) 2008 Marco Túlio Gontijo e Silva +author: Marco Túlio Gontijo e Silva +maintainer: Marco Túlio Gontijo e Silva +synopsis: Generates a version of a module using InterleavableIO +description: + This program generates a version of a module that uses IO a functions, with + MonadIO m => m a when the function returns IO, or InterleavableIO m => m a + when an IO a function is passed as a callback. +category: Monads +tested-with: GHC == 6.8.2 +Executable interleavableGen + main-is: Main.hs + build-depends: base, directory, hint, haskell-src, mtl