diff --git a/hpage.cabal b/hpage.cabal --- a/hpage.cabal +++ b/hpage.cabal @@ -1,5 +1,5 @@ name: hpage -version: 0.10.2 +version: 0.11.0 cabal-version: >=1.6 build-type: Custom license: BSD3 diff --git a/src/HPage/Control.hs b/src/HPage/Control.hs --- a/src/HPage/Control.hs +++ b/src/HPage/Control.hs @@ -29,7 +29,8 @@ -- EDITION CONTROLS -- undo, redo, -- HINT CONTROLS -- - interpret, interpretNth, Interpretation, intKind, intValue, intType, isIntType, + interpret, interpretNth, Interpretation, intKind, intValue, intValues, + intType, isIntType, isIntExprs, valueOf, valueOfNth, kindOf, kindOfNth, typeOf, typeOfNth, loadModules, reloadModules, getLoadedModules, @@ -69,7 +70,7 @@ import HPage.Utils.Log import Data.List (isPrefixOf) import qualified Data.ByteString.Char8 as Str -import qualified Language.Haskell.Exts.Parser as Parser +import qualified Language.Haskell.Exts as Xs import Distribution.Simple.Configure hiding (tryGetConfigStateFile) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Utils @@ -79,14 +80,21 @@ import Distribution.Compiler import qualified HPage.IOServer as HPIO -data Interpretation = Type {intKind :: String} | - Expr {intValue :: String, intType :: String} +data Interpretation = Type {intKind :: String} | + Expr {intValue :: String, intType :: String} | + Exprs {intValues :: [String], intType :: String} deriving (Eq, Show) isIntType :: Interpretation -> Bool -isIntType Type{} = True -isIntType Expr{} = False +isIntType Type{} = True +isIntType Expr{} = False +isIntType Exprs{} = False +isIntExprs :: Interpretation -> Bool +isIntExprs Type{} = False +isIntExprs Expr{} = False +isIntExprs Exprs{} = True + data ModuleDescription = ModDesc {modName :: String, modInterpreted :: Bool} deriving (Eq) @@ -439,43 +447,45 @@ kindRes <- kindOfNth i case kindRes of Left _ -> return $ Left terr - Right k -> return $ Right $ Type{intKind = k} + Right k -> return . Right $ Type{intKind = k} Right t -> do - valueRes <- valueOfNth i - case valueRes of - Left verr -> - if isNotShowable verr - then return $ Right $ Expr{intValue = "", intType = t} - else return $ Left verr - Right v -> return $ Right $ Expr{intValue = v, intType = t} + if isIO t + then do + valueRes <- getIOFromExprNth i + case valueRes of + Right ioAction -> + do + ctx <- get + iores <- liftIO $ HPIO.runIn (ioServer ctx) ioAction + case iores of + Left err -> + return . Left . Hint.UnknownError $ show err + Right r -> + return . Right $ Expr{intValue = r, intType = t} + Left err -> + return $ Left err + else if isList t + then do + valueRes <- getListFromExprNth i + case valueRes of + Left verr -> return $ Left verr + Right list -> return . Right $ Exprs{intValues = list, intType = t} + else do + valueRes <- valueOfNth i + case valueRes of + Left verr -> + if isNotShowable verr + then return $ Right $ Expr{intValue = "", intType = t} + else return $ Left verr + Right v -> return $ Right $ Expr{intValue = v, intType = t} where isNotShowable (Hint.WontCompile ghcerrs) = any complainsAboutShow ghcerrs isNotShowable _ = False complainsAboutShow err = let errMsg = Hint.errMsg err in "No instance for (GHC.Show" `isPrefixOf` errMsg valueOfNth, kindOfNth, typeOfNth :: Int -> HPage (Either Hint.InterpreterError String) -valueOfNth i = - do - res <- runInExprNthWithLets Hint.typeOf i - case res of - Right ('I':'O':' ':_:_) -> -- An IO Action - do - res2 <- getIOFromExprNth i - case res2 of - Right ioAction -> - do - ctx <- get - iores <- liftIO $ HPIO.runIn (ioServer ctx) ioAction - case iores of - Left err -> - return . Left . Hint.UnknownError $ show err - Right r -> - return . Right $ r - Left err -> - return $ Left err - _ -> - runInExprNthWithLets Hint.eval i +valueOfNth i = runInExprNthWithLets Hint.eval i kindOfNth = runInExprNth Hint.kindOf typeOfNth = runInExprNthWithLets Hint.typeOf @@ -599,10 +609,8 @@ exts = uniq . map (read . show) $ concatMap extensions bldinfos opts = uniq $ concatMap (hcOptions GHC) bldinfos libmods = case library pkgdesc of - Nothing -> - [] - Just l -> - libModules l + Nothing -> [] + Just l -> libModules l exemods = concat (map exeModules $ executables pkgdesc) mods = uniq . map (joinWith "." . components) $ exemods ++ libmods action = do @@ -806,6 +814,16 @@ expr = "(" ++ letsToString lets ++ exprText item ++ ") >>= return . show" in syncRun $ Hint.interpret expr (Hint.as :: IO String) +getListFromExprNth :: Int -> HPage (Either Hint.InterpreterError [String]) +getListFromExprNth i = + do + page <- getPage + let exprs = expressions page + flip (withIndex i) exprs $ let (b, item : a) = splitAt i exprs + lets = filter isNamedExpr $ b ++ a + expr = "map show (" ++ letsToString lets ++ exprText item ++ ")" + in syncRun $ Hint.interpret expr (Hint.as :: [String]) + runInExprNthWithLets :: (String -> Hint.InterpreterT IO String) -> Int -> HPage (Either Hint.InterpreterError String) runInExprNthWithLets action i = do page <- getPage @@ -861,9 +879,45 @@ exprFromString s = map Exp $ splitOn "\n\n" s isNamedExpr :: Expression -> Bool -isNamedExpr e = case Parser.parseDecl (exprText e) of - Parser.ParseOk _ -> True - _ -> False +isNamedExpr e = case Xs.parseDecl (exprText e) of + Xs.ParseOk _ -> True + _ -> False + +isType :: (Xs.Type -> Bool) -> String -> Bool +isType f t = case Xs.parseType t of + Xs.ParseOk ty -> f ty + _ -> False -- couldn't parse + +isList :: String -> Bool +isList = isType isList' + +isChar, isList' :: Xs.Type -> Bool +isList' (Xs.TyForall _ _ intType) = isList' intType +isList' (Xs.TyParen intType) = isList' intType +isList' (Xs.TyList intType) = not $ isChar intType +isList' (Xs.TyCon (Xs.Special Xs.ListCon)) = True +isList' _ = False + +isChar (Xs.TyForall _ _ intType) = isChar intType +isChar (Xs.TyParen intType) = isChar intType +isChar (Xs.TyCon (Xs.Qual _ (Xs.Ident "Char"))) = True +isChar (Xs.TyCon (Xs.UnQual (Xs.Ident "Char"))) = True +isChar _ = False + +isIO :: String -> Bool +isIO = isType isIO' + +isIO'', isIO' :: Xs.Type -> Bool +isIO' (Xs.TyForall _ _ intType) = isIO' intType +isIO' (Xs.TyParen intType) = isIO' intType +isIO' (Xs.TyApp intType _) = isIO'' intType +isIO' _ = False + +isIO'' (Xs.TyForall _ _ intType) = isIO'' intType +isIO'' (Xs.TyParen intType) = isIO'' intType +isIO'' (Xs.TyCon (Xs.Qual _ (Xs.Ident "IO"))) = True +isIO'' (Xs.TyCon (Xs.UnQual (Xs.Ident "IO"))) = True +isIO'' _ = False exprFromString' :: String -> Int -> ([Expression], Int) exprFromString' "" 0 = ([], -1) 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 @@ -73,6 +73,9 @@ data GUIBottom = GUIBtm { bottomDesc :: String, _bottomSource :: String } +instance Show GUIBottom where + show = bottomDesc + data GUIResults = GUIRes { resButton :: Button (), resLabel :: StaticText (), resValue :: TextCtrl (), @@ -89,9 +92,9 @@ guiTimer :: TimerEx (), guiCharTimer :: TimerEx (), guiSearch :: FindReplaceData (), - guiChrVar :: MVar (Maybe String), + guiChrVar :: MVar (Maybe (Either GUIBottom String)), guiChrFiller :: MVar (Handle String), - guiValFiller :: MVar (Handle (String, IO ()))} + guiValFiller :: MVar (Handle (HP.Interpretation, IO ()))} gui :: [String] -> IO () gui args = @@ -100,7 +103,7 @@ visible := False] iconFile <- imageFile $ "icon" "hpage" <.> "ico" - iconCreateFromFile iconFile sizeNull >>= topLevelWindowSetIcon win + iconCreateFromFile iconFile sizeNull >>= topLevelWindowSetIcon win ssh <- SS.start win @@ -184,16 +187,13 @@ vf <- spawn $ valueFiller guiCtx putMVar vfv vf - -- Events - timerOnCommand refreshTimer $ refreshExpr model guiCtx - timerOnCommand charTimer $ do - wasEmpty <- tryPutMVar chv Nothing - if wasEmpty - then do - newchf <- spawn $ charFiller guiCtx - swapMVar chfv newchf >>= kill - else return () + -- Timers + timerOnCommand refreshTimer $ debugIO "<>" >> refreshExpr model guiCtx + timerStop refreshTimer + timerOnCommand charTimer $ debugIO "!! runaway kill !!" >> tryPutMVar chv Nothing >> return () + timerStop charTimer + -- Events set btnInterpret [on command := onCmd "interpret" interpret] set lstPages [on select := onCmd "pageChange" pageChange] @@ -384,72 +384,125 @@ SS.step ssh 100 "failed" set win [visible := True] shutdownTimer <- timer win [on command := do - errorDialog win "Error" "Seems like you don't have Cabal installed.\nPlease install the Haskelll Platform from http://hackage.haskell.org/platform/" - wxcAppExit - exitWith errRes] + errorDialog win "Error" "Seems like you don't have Cabal installed.\nPlease install the Haskelll Platform from http://hackage.haskell.org/platform/" + wxcAppExit + exitWith errRes] True <- timerStart shutdownTimer 50 True return () -- PROCESSES ------------------------------------------------------------------- charFiller :: GUIContext -> Process String () -charFiller GUICtx{guiResults = GUIRes{resErrors= varErrors}, - guiChrVar = chv} = +charFiller GUICtx{guiChrVar = chv} = forever $ do t <- recv liftIO $ do - txt <- flip handle (eval t) $ \(ex :: SomeException) -> - varUpdate varErrors (++ [GUIBtm (show ex) t]) >> - return bottomChar - debugIO $ "Writing chv := " ++ txt - tryPutMVar chv $ Just txt - where eval t = t `seq` length t `seq` return t + res <- catchNoKill (eval t) $ \err -> return . Left $ GUIBtm err t + debugIO ("chv", res) + tryPutMVar chv $ Just res + where eval t = t `seq` length t `seq` return (Right t) -valueFiller :: GUIContext -> Process (String, IO ()) () +catchNoKill :: IO a -> (String -> IO a) -> IO a +catchNoKill ioAction handler = + do + res <- handle (\(ex :: SomeException) -> return $ Left ex) $ do + innerRes <- handleJust threadKilled (return . Left) $ ioAction >>= return . Right + return $ Right innerRes + case res of + Left ex -> handler $ show ex + Right (Left ex) -> throw ex + Right (Right r) -> return r + +threadKilled :: AsyncException -> Maybe AsyncException +threadKilled ThreadKilled = Just ThreadKilled +threadKilled _ = Nothing + +-- | Process that receives an interpretation, computes the value(s) of it +-- and fills the txtValue and varErrors with it... +valueFiller :: GUIContext -> Process (HP.Interpretation, IO ()) () valueFiller guiCtx@GUICtx{guiResults = GUIRes{resButton = btnInterpret, resErrors = varErrors, resValue = txtValue}, guiStatus = status} = forever $ do - liftDebugIO "Waiting for a new value to interpret" - (val, poc) <- recv - liftDebugIO "Value received in valueFiller" - liftDebugIO "Trying to evaluate the whole value first..." + liftDebugIO "Waiting for a new interpretation to display" + (interp, poc) <- recv liftIO $ do set txtValue [text := ""] varSet varErrors [] - res <- valueFill guiCtx val - if res == bottomChar - then do - debugIO "didn't work... going char by char..." - varSet varErrors [] - statusText <- valueFiller' guiCtx val - errs <- varGet varErrors - case (statusText, errs) of - ("", []) -> - set status [text := ""] >> - set txtValue [enabled := True, - bgcolor := white] - ("", _) -> - set status [text := "Expression interpreted with errors: Check them by right-clicking on each one"] >> - set txtValue [enabled := True, - bgcolor := yellow] - (msg, _) -> - set status [text := "Expression interpreted with errors: " ++ msg] >> - set txtValue [enabled := True, - bgcolor := yellow] - else do - debugIO "It worked!!" - textCtrlAppendText txtValue res - set status [text := ""] - set txtValue [enabled := True, - bgcolor := white] + statusText <- + if HP.isIntExprs interp + then do + liftDebugIO "Values received in valueFiller" + set txtValue [text := "["] + listValueFiller guiCtx $ HP.intValues interp + return "" -- It can't be a string error as + -- we're generating the string + else do + liftDebugIO "Value received in valueFiller" + singleValueFiller guiCtx $ HP.intValue interp + errs <- varGet varErrors + case (statusText, errs) of + ("", []) -> -- No errors + set status [text := ""] >> + set txtValue [enabled := True, + bgcolor := white] + ("", _) -> -- Char errors + set status [text := "Expression interpreted with errors: Check them by right-clicking on each one"] >> + set txtValue [enabled := True, + bgcolor := yellow] + (msg, _) -> -- String error + set status [text := "Expression interpreted with errors: " ++ msg] >> + set txtValue [enabled := True, + bgcolor := yellow] set btnInterpret [on command := poc, text := "Interpret"] -valueFiller' :: GUIContext -> String -> IO String -valueFiller' guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue}} val = - do - h <- try (case val of +-- | Processes the string, computes its value and appends it to the txtValue +-- or appends the errors generated by its computation to varErrors, returning +-- the error description if there was an error. +listValueFiller :: GUIContext -> [String] -> IO () +listValueFiller GUICtx{guiResults = GUIRes{resValue = txtValue}} [] = + textCtrlAppendText txtValue "]" >> return () +listValueFiller guiCtx@GUICtx{guiResults = + GUIRes{resErrors = varErrors, + resValue = txtValue}} (v:vs) = + do + debugIO "List Value Filler running for a value..." + status <- singleValueFiller guiCtx v + debugIO $ "...value processed: " ++ status + _errs <- case status of + "" -> return [] + err -> textCtrlAppendText txtValue bottomString >> + varUpdate varErrors (++ [GUIBtm err v]) + textCtrlAppendText txtValue $ if vs /= [] then ", " else "" + listValueFiller guiCtx vs + +-- | Processes the string, computes its value and appends it to the txtValue +-- or appends the errors generated by its computation to varErrors, returning +-- the error description if there was an error. +singleValueFiller :: GUIContext -> String -> IO String +singleValueFiller guiCtx@GUICtx{guiResults = GUIRes{resErrors = varErrors, + resValue = txtValue}} val = + do + liftDebugIO "Trying to evaluate the whole value first..." + res <- valueFill guiCtx val + if res == bottomChar + then do + debugIO "didn't work... going char by char..." + varSet varErrors [] + recursiveValueFiller guiCtx val + else do + debugIO "It worked!!" + textCtrlAppendText txtValue res + set txtValue [enabled := True, + bgcolor := white] + return "" -- No errors + +-- | Same as singleValueFiller but going char by char +recursiveValueFiller :: GUIContext -> String -> IO String +recursiveValueFiller guiCtx@GUICtx{guiResults = GUIRes{resValue = txtValue}} val = + do + h <- try (case val of [] -> return [] (c:_) -> return [c]) case h of @@ -460,13 +513,13 @@ Right t -> do valueFill guiCtx t >>= textCtrlAppendText txtValue - valueFiller' guiCtx $ tail val + recursiveValueFiller guiCtx $ tail val valueFill :: GUIContext -> String -> IO String -valueFill GUICtx{guiResults = GUIRes{resErrors = varErrors}, - guiCharTimer = charTimer, - guiChrVar = chv, - guiChrFiller = chfv} val = +valueFill guiCtx@GUICtx{guiResults = GUIRes{resErrors = varErrors}, + guiCharTimer = charTimer, + guiChrVar = chv, + guiChrFiller = chfv} val = do debugIO "valueFill starting..." _ <- tryTakeMVar chv --NOTE: empty the var @@ -478,16 +531,20 @@ toAdd <- readMVar chv --NOTE: Not using "take" to be sure that noone touches it debugIO ("Ready to add...", toAdd) case toAdd of - Just txt -> + Just res -> do isR <- timerIsRuning charTimer + debugIO $ (if isR then "" else "not-") ++ "Stopping the charTimer" if isR then timerStop charTimer else return () - debugIO $ "returning " ++ txt - return txt + case res of + Left btm -> varUpdate varErrors (++ [btm]) >> return bottomChar + Right txt -> return txt Nothing -> --NOTE: Means "Timed Out" do _newVal <- varUpdate varErrors (++ [GUIBtm "Timed Out" val]) - debugIO $ "timed out" + debugIO "Timed out >> swapping the charFiller" + newchf <- spawn $ charFiller guiCtx + swapMVar chfv newchf >>= kill return bottomChar -- EVENT HANDLERS -------------------------------------------------------------- @@ -543,11 +600,11 @@ Left err -> menuAppend browseMenu idAny err "Error" False Right mes -> - flip mapM_ mes $ createMenuItem browseMenu - _copy <- menuItem contextMenu [text := "To Clipboard", - on command := addToClipboard mn] + forM_ mes $ createMenuItem browseMenu + _copy <- menuItem contextMenu [text := "Copy", + on command := addToClipboard mn] _search <- menuItem contextMenu [text := "Search on Hayoo!", - on command := hayooDialog win mn] + on command := hayooDialog win mn] menuAppendSeparator contextMenu menuAppendSub contextMenu wxId_HASK_BROWSE "&Browse" browseMenu "" addToClipboard txt = @@ -576,7 +633,7 @@ do subMenu <- createBasicMenuItem cn menuAppendSeparator subMenu - flip mapM_ cfs $ createMenuItem subMenu + forM_ cfs $ createMenuItem subMenu menuAppendSub m wxId_HASK_MENUELEM ("class " ++ cn) subMenu "" createMenuItem m HP.MEData{HP.datName = dn, HP.datCtors = []} = do @@ -586,15 +643,15 @@ do subMenu <- createBasicMenuItem dn menuAppendSeparator subMenu - flip mapM_ dcs $ createMenuItem subMenu + forM_ dcs $ createMenuItem subMenu menuAppendSub m wxId_HASK_MENUELEM ("data " ++ dn) subMenu "" createBasicMenuItem name = do itemMenu <- menuPane [] - _copy <- menuItem itemMenu [text := "To Clipboard", - on command := addToClipboard name] + _copy <- menuItem itemMenu [text := "Copy", + on command := addToClipboard name] _search <- menuItem itemMenu [text := "Search on Hayoo!", - on command := hayooDialog win name] + on command := hayooDialog win name] return itemMenu @@ -673,7 +730,7 @@ fs -> do set status [text := "opening..."] - flip mapM_ fs $ \f -> runHP' (HP.openPage f) model guiCtx + forM_ fs $ \f -> runHP' (HP.openPage f) model guiCtx savePageAs model guiCtx@GUICtx{guiWin = win, guiStatus = status} = do @@ -867,14 +924,14 @@ do -- Refresh the pages list itemsDelete lstPages - (flip mapM_) ps $ \pd -> - let prefix = if HP.pIsModified pd - then "*" - else "" - name = case HP.pPath pd of - Nothing -> "new page" - Just fn -> takeFileName $ dropExtension fn - in itemAppend lstPages $ prefix ++ name + forM_ ps $ \pd -> + let prefix = if HP.pIsModified pd + then "*" + else "" + name = case HP.pPath pd of + Nothing -> "new page" + Just fn -> takeFileName $ dropExtension fn + in itemAppend lstPages $ prefix ++ name set lstPages [selection := i] -- Refresh the modules lists @@ -888,9 +945,9 @@ flip filter pms $ \pm -> all (\xm -> HP.modName xm /= pm) ms allms = zip [0..] (ims' ++ ms' ++ pms') itemsDelete lstModules - (flip mapM_) allms $ \(idx, (img, m@(mn:_))) -> - listCtrlInsertItemWithLabel lstModules idx mn img >> - set lstModules [item idx := m] + forM_ allms $ \(idx, (img, m@(mn:_))) -> + listCtrlInsertItemWithLabel lstModules idx mn img >> + set lstModules [item idx := m] varSet varModsSel $ -1 -- Refresh the current text @@ -953,11 +1010,11 @@ guiChrFiller = chfv, guiStatus = status} = do - -- Cancel if needed... - btnText <- get btnInterpret text - if btnText == "Cancel" - then get btnInterpret (on command) >>= liftIO - else return () + -- Cancel if needed... + btnText <- get btnInterpret text + if btnText == "Cancel" + then get btnInterpret (on command) >>= liftIO + else return () sel <- textCtrlGetStringSelection txtCode let runner = case sel of "" -> tryIn @@ -990,28 +1047,30 @@ poc <- liftIO $ get btnInterpret $ on command let revert = do debugIO "Cancelling..." + newvf <- spawn $ valueFiller guiCtx + debugIO "Killing the value filler..." + swapMVar vfv newvf >>= kill + debugIO "...valueFiller swapped" _ <- tryTakeMVar chv --NOTE: empty the var - debugIO "Killing the char filler..." newchf <- spawn $ charFiller guiCtx + debugIO "Killing the char filler..." swapMVar chfv newchf >>= kill - debugIO "Killing the value filler..." - newvf <- spawn $ valueFiller guiCtx - swapMVar vfv newvf >>= kill - debugIO "Ready" + debugIO "...charFiller swapped" errs <- varGet varErrors set status [text := case errs of - [] -> "" - _ -> "Expression interpreted with errors: Check them by right-clicking on each one"] + [] -> "" + _ -> "Expression interpreted with errors: Check them by right-clicking on each one"] set txtValue [enabled := True, bgcolor := case errs of [] -> white _ -> yellow] + debugIO "...cancelled" set btnInterpret [text := "Interpret", - on command := poc] + on command := poc] in liftIO $ set btnInterpret [text := "Cancel", on command := revert] - liftDebugIO "sending the value to the Value Filler..." - readMVar vfv >>= flip sendTo ((HP.intValue interp), poc) + liftDebugIO "sending the value to the Value(s) Filler..." + readMVar vfv >>= flip sendTo (interp, poc) runTxtHPSelection :: String -> HPS.ServerHandle -> HP.HPage (Either HP.InterpreterError HP.Interpretation) -> IO (Either ErrorString HP.Interpretation)