diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -36,3 +36,4 @@ /src/Fluid/Parser.hi /src/Fluid/Types.hi /TAGS +/.stack-work/* diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -69,39 +69,7 @@ fltkcdir = unsafePerformIO getCurrentDirectory ++ "/c-lib" fltkclib = "fltkc" -headerdir = unsafePerformIO getCurrentDirectory ++ "/c-src" -currentdir :: FilePath -currentdir = unsafePerformIO getCurrentDirectory -getHeaders :: [FilePath] -getHeaders = unsafePerformIO $ do - contents <- getDirectoryContents headerdir - let headerFiles = filter (\f -> takeExtension f == ".h" -- keep the headers - && - not (takeBaseName f `isPrefixOf` "Derived") -- but not the extra classes - ) contents - return headerFiles -objectFileDir = unsafePerformIO getCurrentDirectory ++ "/static_object_files" -getObjectFileDirContents = getDirectoryContents objectFileDir -addIncludeDirs pd = - let lib = (fromJust . library) pd - bi = libBuildInfo lib - ids = includeDirs bi - bi' = bi {includeDirs = ids ++ [headerdir, currentdir]} - lib' = lib {libBuildInfo = bi'} - in - pd {library = Just lib'} - -addHeaders pd = - let lib = (fromJust . library) pd - bi = libBuildInfo lib - is = includes bi - headers = getHeaders - bi' = bi {includes = is ++ headers} - lib' = lib {libBuildInfo = bi'} - in - pd {library = Just lib'} - withFltkc op pd = let lib = (fromJust . library) pd bi = libBuildInfo lib @@ -112,41 +80,6 @@ in pd {library = Just lib'} -removeExecutables pd = pd {executables = []} - -getHaskellObjects :: Library -> LocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let splitSuffix = if compilerVersion (compiler lbi) < - Version [6, 11] [] - then "_split" - else "_" ++ wanted_obj_ext ++ "_split" - dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- libModules lib ] - objss <- mapM getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- libModules lib ] - --- This copy-pasta is required because Distribution.Simple.Build does --- not export buildExe. -buildExe :: Verbosity -> Distribution.Simple.Setup.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity numJobs pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi - JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi - LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die "Building is not supported with this compiler." - myBuildHook pkg_descr local_bld_info user_hooks bld_flags = do let compileC = do putStrLn "==Compiling C bindings==" @@ -158,53 +91,8 @@ clibraries <- getDirectoryContents fltkcdir when (null $ filter (Data.List.isInfixOf "fltkc") clibraries) compileC else compileC - let new_pkg_descr - = removeExecutables . addHeaders . addIncludeDirs . withFltkc (++) $ pkg_descr - new_local_bld_info = local_bld_info{localPkgDescr = new_pkg_descr} - (libs, nonlibs) - = partition - (\ c -> - case c of - (CLibName, _, _) -> True - _ -> False) - (componentsConfigs new_local_bld_info) - lib_lbi = new_local_bld_info{componentsConfigs = libs} - buildHook defaultUserHooks new_pkg_descr lib_lbi user_hooks bld_flags - let distPref = fromFlag (buildDistPref bld_flags) - dbFile = distPref "package.conf.inplace" - verbosity = fromFlag (buildVerbosity bld_flags) - with_in_place - = local_bld_info{withPackageDB = - withPackageDB local_bld_info ++ [SpecificPackageDB dbFile] - } - pref = buildDir local_bld_info - withAllComponentsInBuildOrder pkg_descr with_in_place $ - \ comp clbi -> - case comp of - (CLib lib) -> do cobjs <- getObjectFileDirContents >>= - return . - map (combine objectFileDir) . - filter (\ f -> case buildOS of - Windows -> takeExtension f == ".obj" - _ -> takeExtension f == ".o") - hobjs <- getHaskellObjects lib with_in_place pref objExtension True - let staticObjectFiles = hobjs ++ cobjs - (arProg, _ ) <- requireProgram verbosity arProgram - (withPrograms with_in_place) - let vanillaLibFilePath - = pref mkLibName (head $ componentLibraries clbi) - Ar.createArLibArchive verbosity with_in_place vanillaLibFilePath - staticObjectFiles - (CExe exe) -> do preprocessComponent pkg_descr comp - with_in_place - False - verbosity - [] - buildExe verbosity (buildNumJobs bld_flags) pkg_descr - with_in_place - exe - clbi - _ -> return () + let new_pkg_descr = withFltkc (++) pkg_descr + buildHook defaultUserHooks new_pkg_descr local_bld_info user_hooks bld_flags copyCBindings :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () copyCBindings pkg_descr lbi uhs flags = do @@ -217,7 +105,6 @@ case buildOS of Linux -> rawSystemExit (fromFlag $ copyVerbosity flags) "cp" ["c-lib/libfltkcdyn.so", libPref] - myCleanHook pd x uh cf = do rawSystemExit normal "make" ["clean"] diff --git a/fltkhs.cabal b/fltkhs.cabal --- a/fltkhs.cabal +++ b/fltkhs.cabal @@ -1,5 +1,5 @@ name : fltkhs -version : 0.3.0.0 +version : 0.3.0.1 synopsis : FLTK bindings description: Low level bindings for the FLTK GUI toolkit. @@ -121,7 +121,7 @@ base == 4.*, filepath, fltkhs, - parsec, + parsec >= 3.1.6, mtl default-language: Haskell2010 ghc-Options: -Wall -threaded -fcontext-stack=300 diff --git a/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs b/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs --- a/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Fl_Enumerations.chs @@ -172,7 +172,6 @@ ) where import C2HS -import System.IO.Unsafe #c enum VersionInfo { MajorVersion = FL_MAJOR_VERSION, diff --git a/src/Graphics/UI/FLTK/LowLevel/Table.chs b/src/Graphics/UI/FLTK/LowLevel/Table.chs --- a/src/Graphics/UI/FLTK/LowLevel/Table.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Table.chs @@ -111,10 +111,10 @@ CustomWidgetFuncs a -> CustomTableFuncs b -> IO (Ptr ()) -tableCustomFunctionStruct draw' drawCell' customWidgetFuncs' customTableFuncs' = +tableCustomFunctionStruct draw'' drawCell' customWidgetFuncs' customTableFuncs' = do ptr <- virtualFuncs' - fillCustomWidgetFunctionStruct ptr draw' customWidgetFuncs' + fillCustomWidgetFunctionStruct ptr draw'' customWidgetFuncs' fillCustomTableFunctionStruct ptr drawCell' customTableFuncs' return ptr @@ -127,10 +127,10 @@ -> CustomWidgetFuncs Table -- ^ Widget overrides -> CustomTableFuncs Table -- ^ Table overrides -> IO (Ref Table) -tableCustom rectangle label' draw' drawCell' customWidgetFuncs' customTableFuncs' = +tableCustom rectangle label' draw'' drawCell' customWidgetFuncs' customTableFuncs' = do let (x_pos, y_pos, width, height) = fromRectangle rectangle - ptr <- tableCustomFunctionStruct draw' (Just drawCell') customWidgetFuncs' customTableFuncs' + ptr <- tableCustomFunctionStruct draw'' (Just drawCell') customWidgetFuncs' customTableFuncs' case label' of (Just l') -> tableNewWithLabel' x_pos y_pos width height l' ptr >>= toRef Nothing -> tableNew' x_pos y_pos width height ptr >>= toRef diff --git a/src/Graphics/UI/FLTK/LowLevel/Tree.chs b/src/Graphics/UI/FLTK/LowLevel/Tree.chs --- a/src/Graphics/UI/FLTK/LowLevel/Tree.chs +++ b/src/Graphics/UI/FLTK/LowLevel/Tree.chs @@ -113,8 +113,8 @@ runOp _ _ tree item = withRef tree $ \treePtr -> withRef item $ \itemPtr -> nextWithItem' treePtr itemPtr >>= toMaybeRef {# fun Fl_Tree_next_item as nextItem' { id `Ptr ()',id `Ptr ()', id `CInt', cFromBool `Bool'} -> `Ptr ()' id #} instance (impl ~ (Ref TreeItem -> Maybe SearchDirection -> Bool -> IO (Maybe (Ref TreeItem))) ) => Op (NextItem ()) Tree orig impl where - runOp _ _ tree item dir visible = - withRef tree $ \treePtr -> withRef item $ \itemPtr -> nextItem' treePtr itemPtr (maybe 0 (fromIntegral . fromEnum) dir) visible + runOp _ _ tree item dir visible' = + withRef tree $ \treePtr -> withRef item $ \itemPtr -> nextItem' treePtr itemPtr (maybe 0 (fromIntegral . fromEnum) dir) visible' >>= toMaybeRef {# fun Fl_Tree_prev as prev' { id `Ptr ()' } -> `Ptr ()' id #} instance (impl ~ ( IO (Maybe (Ref TreeItem))) ) => Op (Prev ()) Tree orig impl where diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,31 @@ +# For more information, see: https://github.com/commercialhaskell/stack/blob/master/doc/yaml_configuration.md + +# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) +resolver: lts-3.8 + +# Local packages, usually specified by relative directory name +packages: +- '.' + +# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) +extra-deps: [] + +# Override default flag values for local packages and extra-deps +flags: + fltkhs: + fastcompile: true + +# Control whether we use the GHC we find on the path +# system-ghc: true + +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: >= 0.1.4.0 + +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 + +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir]