hpage 0.10.2 → 0.11.0
raw patch · 3 files changed
+259/−146 lines, 3 files
Files
- hpage.cabal +1/−1
- src/HPage/Control.hs +96/−42
- src/HPage/GUI/FreeTextWindow.hs +162/−103
hpage.cabal view
@@ -1,5 +1,5 @@ name: hpage-version: 0.10.2+version: 0.11.0 cabal-version: >=1.6 build-type: Custom license: BSD3
src/HPage/Control.hs view
@@ -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)
src/HPage/GUI/FreeTextWindow.hs view
@@ -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 "<<refresh>>" >> 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)