interleavableGen (empty) → 0.0.1

raw patch · 4 files changed

+366/−0 lines, 4 filesdep +basedep +directorydep +haskell-srcsetup-changed

Dependencies added: base, directory, haskell-src, hint, mtl

Files

• LICENSE +19/−0
• Main.hs +326/−0
• Setup.hs +2/−0
• interleavableGen.cabal +19/−0

@@ -0,0 +1,19 @@+Copyright (c) 2008 Marco Túlio Gontijo e Silva <marcot@riseup.net>++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.

@@ -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 <marcot@riseup.net>\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] <Module>...\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+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <marcot@riseup.net>+author: Marco Túlio Gontijo e Silva+maintainer: Marco Túlio Gontijo e Silva <marcot@riseup.net>+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