diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.4 +version: 0.4.1 cabal-version: >=1.6 build-type: Custom license: BSD3 @@ -20,6 +20,7 @@ res/images/icon/hPage.icns res/images/icon/hpage.tif res/help/helpPage.hs + res/test/*.hs data-dir: "" extra-source-files: Setup.hs extra-tmp-files: @@ -41,25 +42,17 @@ wx >=0.11.1, wx < 0.12, filepath >=1.1.0, filepath < 1.2, Cabal >= 1.6, Cabal < 1.7, - MissingH >= 1.1, MissingH < 1.2, hint >=0.3.1, hint < 0.4, eprocess >= 1.0.0, eprocess < 2, hint-server >= 1.0.0, hint-server < 2 main-is: Main.hs buildable: True - extensions: CPP hs-source-dirs: src - other-modules: - HPage.GUI.IDs, + other-modules: HPage.GUI.IDs, HPage.GUI.FreeTextWindow, HPage.GUI.Dialogs, HPage.Control, HPage.Server, HPage.Test.Server, - HPage.Test.Extensions.FlexibleInstances, - HPage.Test.Extensions.OverlappingInstances, - HPage.Test.Extensions.TypeSynonymInstances, HPage.Utils.Log - ghc-prof-options: -auto-all -prof - ghc-shared-options: -auto-all -prof ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns diff --git a/res/test/FlexibleInstances.hs b/res/test/FlexibleInstances.hs new file mode 100644 --- /dev/null +++ b/res/test/FlexibleInstances.hs @@ -0,0 +1,4 @@ + +instance Functor (Either Int) where + fmap _ (Left n) = Left n + fmap f (Right r) = Right (f r) diff --git a/res/test/OverlappingInstances.hs b/res/test/OverlappingInstances.hs new file mode 100644 --- /dev/null +++ b/res/test/OverlappingInstances.hs @@ -0,0 +1,13 @@ +import Data.List + +class Foo a where + foo :: a -> String + +instance Foo a => Foo [a] where + foo = concat . intersperse ", " . map foo + +instance Foo Char where + foo c = [c] + +instance Foo String where + foo = id diff --git a/res/test/TypeSynonymInstances.hs b/res/test/TypeSynonymInstances.hs new file mode 100644 --- /dev/null +++ b/res/test/TypeSynonymInstances.hs @@ -0,0 +1,5 @@ +class ExtTest a where + extes :: a -> String + +instance ExtTest String where + extes = show . map show diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -40,7 +40,8 @@ getGhcOpts, setGhcOpts, loadPackage, valueOf', valueOfNth', kindOf', kindOfNth', typeOf', typeOfNth', - loadModules', reloadModules', getLoadedModules', importModules', getImportedModules', + loadModules', + reloadModules', getLoadedModules', importModules', getImportedModules', getModuleExports', getLanguageExtensions', setLanguageExtensions', getSourceDirs', setSourceDirs', @@ -49,7 +50,7 @@ cancel, Hint.InterpreterError, prettyPrintError, Hint.availableExtensions, Hint.Extension(..), - ModuleElemDesc(..), + ModuleDescription(..), ModuleElemDesc(..), -- DEBUG -- ctxString ) where @@ -70,7 +71,6 @@ import qualified Language.Haskell.Interpreter.Server as HS import HPage.Utils.Log import Data.List (isPrefixOf) -import Data.List.Utils import qualified Data.List as List import qualified Data.ByteString.Char8 as Str import qualified Language.Haskell.Exts.Parser as Parser @@ -81,6 +81,13 @@ import Distribution.ModuleName import Distribution.Compiler +data ModuleDescription = ModDesc {modName :: String, + modInterpreted :: Bool} + deriving (Eq) + +instance Show ModuleDescription where + show m = show (modName m, modInterpreted m) + data ModuleElemDesc = MEFun {funName :: String, funType :: String} | MEClass {clsName :: String, @@ -454,8 +461,13 @@ Hint.loadModules ms Hint.getLoadedModules >>= Hint.setTopLevelModules -getLoadedModules :: HPage (Either Hint.InterpreterError [Hint.ModuleName]) -getLoadedModules = confirmRunning >> syncRun Hint.getLoadedModules +getLoadedModules :: HPage (Either Hint.InterpreterError [ModuleDescription]) +getLoadedModules = do + confirmRunning + syncRun $ do + mns <- Hint.getLoadedModules + mis <- mapM Hint.isModuleInterpreted mns + return $ zipWith ModDesc mns mis getImportedModules :: HPage [Hint.ModuleName] getImportedModules = confirmRunning >>= return . toList . importedModules @@ -605,9 +617,14 @@ Hint.loadModules ms Hint.getLoadedModules >>= Hint.setTopLevelModules -getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [Hint.ModuleName])) -getLoadedModules' = confirmRunning >> asyncRun Hint.getLoadedModules - +getLoadedModules' :: HPage (MVar (Either Hint.InterpreterError [ModuleDescription])) +getLoadedModules' = do + confirmRunning + asyncRun $ do + mns <- Hint.getLoadedModules + mis <- mapM Hint.isModuleInterpreted mns + return $ zipWith ModDesc mns mis + getImportedModules' :: HPage (MVar [Hint.ModuleName]) getImportedModules' = confirmRunning >>= liftIO . newMVar . toList . importedModules @@ -848,3 +865,18 @@ moduleElemDesc (Hint.Data dn dcs) = do mdcs <- flip mapM dcs $ moduleElemDesc . Hint.Fun return MEData{datName = dn, datCtors = mdcs} + +{- | Given a list, returns a new list with all duplicate elements removed. +For example: + +>uniq "Mississippi" -> "Misp" + +You should not rely on this function necessarily preserving order, though +the current implementation happens to. + +This function is not compatible with infinite lists. + +TAKEN FROM: http://hackage.haskell.org/packages/archive/MissingH/1.0.0/doc/html/src/Data-List-Utils.html#uniq -} +uniq :: Eq a => [a] -> [a] +uniq [] = [] +uniq (x:xs) = x : uniq (filter (/= x) xs) diff --git a/src/HPage/GUI/FreeTextWindow.hs b/src/HPage/GUI/FreeTextWindow.hs --- a/src/HPage/GUI/FreeTextWindow.hs +++ b/src/HPage/GUI/FreeTextWindow.hs @@ -584,7 +584,7 @@ --NOTE: we know 0 == "imported" / 1 == "interpreted" / 2 == "compiled" images --TODO: move that to some kind of constants or so let ims' = map (\m -> (0, m)) ims - ms' = map (\m -> (1, m)) ms --TODO: Verify if it is intrepreted + ms' = map (\m -> (if HP.modInterpreted m then 1 else 2, HP.modName m)) ms allms = zip [0..] (ims' ++ ms') itemsDelete lstLoadedModules (flip mapM) allms $ \(idx, (img, m)) -> @@ -592,7 +592,7 @@ set lstLoadedModules [item idx := [m]] itemsDelete lstPkgModules - (flip mapM) pms $ \pm -> itemAppend lstPkgModules (if pm `elem` ms then ('*':pm) else pm) + (flip mapM) pms $ \pm -> itemAppend lstPkgModules (if any (\xm -> HP.modName xm == pm) ms then ('*':pm) else pm) -- Refresh the current text set txtCode [text := t] diff --git a/src/HPage/Test/Extensions/FlexibleInstances.hs b/src/HPage/Test/Extensions/FlexibleInstances.hs deleted file mode 100644 --- a/src/HPage/Test/Extensions/FlexibleInstances.hs +++ /dev/null @@ -1,4 +0,0 @@ - -instance Functor (Either Int) where - fmap _ (Left n) = Left n - fmap f (Right r) = Right (f r) diff --git a/src/HPage/Test/Extensions/OverlappingInstances.hs b/src/HPage/Test/Extensions/OverlappingInstances.hs deleted file mode 100644 --- a/src/HPage/Test/Extensions/OverlappingInstances.hs +++ /dev/null @@ -1,13 +0,0 @@ -import Data.List - -class Foo a where - foo :: a -> String - -instance Foo a => Foo [a] where - foo = concat . intersperse ", " . map foo - -instance Foo Char where - foo c = [c] - -instance Foo String where - foo = id diff --git a/src/HPage/Test/Extensions/TypeSynonymInstances.hs b/src/HPage/Test/Extensions/TypeSynonymInstances.hs deleted file mode 100644 --- a/src/HPage/Test/Extensions/TypeSynonymInstances.hs +++ /dev/null @@ -1,5 +0,0 @@ -class ExtTest a where - extes :: a -> String - -instance ExtTest String where - extes = show . map show diff --git a/src/HPage/Test/Server.hs b/src/HPage/Test/Server.hs --- a/src/HPage/Test/Server.hs +++ b/src/HPage/Test/Server.hs @@ -13,7 +13,7 @@ import Control.Monad.Loops import qualified Data.ByteString.Char8 as Str import HPage.Utils.Log --- import Data.Set (fromList) +import Paths_hpage instance Arbitrary Char where arbitrary = elements (['A'..'Z'] ++ ['a' .. 'z']) @@ -61,14 +61,14 @@ coarbitrary _ = undefined wexTypeSynonymInstances :: WorkingExtension -wexTypeSynonymInstances = WEX [HP.TypeSynonymInstances] "HPage/Test/Extensions/TypeSynonymInstances.hs" +wexTypeSynonymInstances = WEX [HP.TypeSynonymInstances] "TypeSynonymInstances.hs" wexOverlappingInstances :: WorkingExtension wexOverlappingInstances = WEX [HP.TypeSynonymInstances, - HP.OverlappingInstances] "HPage/Test/Extensions/OverlappingInstances.hs" + HP.OverlappingInstances] "OverlappingInstances.hs" wexFlexibleInstances :: WorkingExtension -wexFlexibleInstances = WEX [HP.FlexibleInstances] "HPage/Test/Extensions/FlexibleInstances.hs" +wexFlexibleInstances = WEX [HP.FlexibleInstances] "FlexibleInstances.hs" shouldFail :: (MonadError e m) => m a -> m Bool shouldFail a = (a >> return False) `catchError` (\_ -> return True) @@ -244,12 +244,12 @@ HP.loadModules [testDir ++ "/test.hs"] HP.setPageText "v" 0 fv <- HP.valueOf - fm <- HP.getLoadedModules + fm <- HP.getLoadedModules >>= return . mN -- Load TestFiles/Test...hs by name HP.loadModules [mname] HP.setPageText "v" 0 sv <- HP.valueOf - sm <- HP.getLoadedModules + sm <- HP.getLoadedModules >>= return . mN return (fv, sv, fm, sm) hsr <- HS.runIn hs $ do Hint.loadModules [testDir ++ "/test.hs"] @@ -263,6 +263,9 @@ return (Right fv, Right sv, Right fm, Right sm) -- liftDebugIO (hpsr, hsr) return $ Right hpsr == hsr + where mN (Right mns) = Right $ map HP.modName mns + mN (Left err) = Left err + prop_reload_modules :: HPS.ServerHandle -> HS.ServerHandle -> String -> Bool prop_reload_modules hps hs txt = @@ -304,8 +307,10 @@ hpsr3 <- HPS.runIn hps $ HP.loadModules [mnf3] >> HP.getLoadedModules hsr3 <- HS.runIn hs $ Hint.loadModules [mnf3] >> Hint.getLoadedModules --liftDebugIO [(hpsr1, hpsr2, hpsr3), (hsr1, hsr2, hsr3)] - return $ (hpsr1, hpsr2, hpsr3) == (hsr1, hsr2, hsr3) - + return $ (mN hpsr1, mN hpsr2, mN hpsr3) == (hsr1, hsr2, hsr3) + where mN (Right mns) = Right $ map HP.modName mns + mN (Left err) = Left err + prop_sequential :: HPS.ServerHandle -> String -> Bool prop_sequential hps txt = unsafePerformIO $ do @@ -993,10 +998,11 @@ prop_working_extensions :: HPS.ServerHandle -> WorkingExtension -> Bool prop_working_extensions hps (WEX es m) = unsafePerformIO $ HPS.runIn hps $ do + path <- Hint.liftIO . getDataFileName $ "res/test/" ++ m HP.setLanguageExtensions [] - before <- HP.loadModules [m] + before <- HP.loadModules [path] HP.setLanguageExtensions es - after <- HP.loadModules [m] + after <- HP.loadModules [path] let failed = case before of Left _ -> True _ -> False