diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/.gitignore b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/.gitignore new file mode 100644 index 0000000..842e66d --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/.gitignore @@ -0,0 +1,8 @@ +# Build artifacts +dist/ +*.hi +*.o + +# Operating system rubbish +.DS_Store +Thumbs.db diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/LICENSE b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/LICENSE new file mode 100644 index 0000000..eaaefde --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2008, Maximilian Bolingbroke +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/README.textile b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/README.textile new file mode 100644 index 0000000..3e651c4 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/README.textile @@ -0,0 +1,3 @@ +h1. ANSI Terminal + +For all information on this package, please consult the "homepage":http://batterseapower.github.com/ansi-terminal \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/Setup.lhs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/Setup.lhs new file mode 100644 index 0000000..d20eadb --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI.hs new file mode 100644 index 0000000..8a72033 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI.hs @@ -0,0 +1,48 @@ +-- | Provides ANSI terminal support for Windows and ANSI terminal software running on a Unix-like operating system. +-- +-- The ANSI escape codes are described at and provide a rich range of +-- functionality for terminal control, which includes: +-- +-- * Colored text output, with control over both foreground and background colors +-- +-- * Hiding or showing the cursor +-- +-- * Moving the cursor around +-- +-- * Clearing parts of the screen +-- +-- The most frequently used parts of this ANSI command set are exposed with a platform independent interface by +-- this module. Every function exported comes in three flavours: +-- +-- * Vanilla: has an @IO ()@ type and doesn't take a @Handle@. This just outputs the ANSI command directly on +-- to the terminal corresponding to stdout. Commands issued like this should work as you expect on both Windows +-- and Unix. +-- +-- * Chocolate: has an @IO ()@ type but takes a @Handle@. This outputs the ANSI command on the terminal corresponding +-- to the supplied handle. Commands issued like this should also work as your expect on both Windows and Unix. +-- +-- * Strawberry: has a @String@ type and just consists of an escape code which can be added to any other bit of text +-- before being output. This version of the API is often convenient to use, but due to fundamental limitations in +-- Windows ANSI terminal support will only work on Unix. On Windows these codes will always be the empty string, +-- so it is possible to use them portably for e.g. coloring console output on the understanding that you will only +-- see colors if you are running on a Unix-like operating system. +#if defined(WINDOWS) +module System.Console.ANSI ( + module System.Console.ANSI.Windows + ) where + +import System.Console.ANSI.Windows + +#elif defined(UNIX) + +module System.Console.ANSI ( + module System.Console.ANSI.Unix + ) where + +import System.Console.ANSI.Unix + +#else + +#error Unsupported platform for the ansi-terminal package + +#endif \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Common.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Common.hs new file mode 100644 index 0000000..b1aebb5 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Common.hs @@ -0,0 +1,53 @@ +module System.Console.ANSI.Common where + +import Data.Ix + +-- | ANSI colors: come in various intensities, which are controlled by 'ColorIntensity' +data Color = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI colors come in two intensities +data ColorIntensity = Dull + | Vivid + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI colors can be set on two different layers +data ConsoleLayer = Foreground + | Background + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI blink speeds: values other than 'NoBlink' are not widely supported +data BlinkSpeed = SlowBlink -- ^ Less than 150 blinks per minute + | RapidBlink -- ^ More than 150 blinks per minute + | NoBlink + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI text underlining +data Underlining = SingleUnderline + | DoubleUnderline -- ^ Not widely supported + | NoUnderline + deriving (Eq, Ord, Bounded ,Enum, Show, Read, Ix) + +-- | ANSI general console intensity: usually treated as setting the font style (e.g. 'BoldIntensity' causes text to be bold) +data ConsoleIntensity = BoldIntensity + | FaintIntensity -- ^ Not widely supported: sometimes treated as concealing text + | NormalIntensity + deriving (Eq, Ord, Bounded, Enum, Show, Read, Ix) + +-- | ANSI Select Graphic Rendition command +data SGR = Reset + | SetConsoleIntensity ConsoleIntensity + | SetItalicized Bool -- ^ Not widely supported: sometimes treated as swapping foreground and background + | SetUnderlining Underlining + | SetBlinkSpeed BlinkSpeed + | SetVisible Bool -- ^ Not widely supported + | SetSwapForegroundBackground Bool + | SetColor ConsoleLayer ColorIntensity Color + deriving (Eq, Ord, Show, Read) diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Example.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Example.hs new file mode 100644 index 0000000..7c77602 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Example.hs @@ -0,0 +1,267 @@ +module Main ( + main + ) where + +import System.Console.ANSI + +import System.IO + +import Control.Concurrent +import Control.Monad + + +examples :: [IO ()] +examples = [ cursorMovementExample + , lineChangeExample + , setCursorPositionExample + , clearExample + , scrollExample + , sgrExample + , cursorVisibilityExample + , titleExample + ] + +main :: IO () +main = mapM_ (\example -> resetScreen >> example) examples + +resetScreen :: IO () +resetScreen = clearScreen >> setSGR [Reset] >> setCursorPosition 0 0 + +pause :: IO () +pause = do + hFlush stdout + -- 1 second pause + threadDelay 1000000 + +cursorMovementExample :: IO () +cursorMovementExample = do + putStrLn "Line One" + putStr "Line Two" + pause + -- Line One + -- Line Two + + cursorUp 1 + putStr " - Extras" + pause + -- Line One - Extras + -- Line Two + + cursorBackward 2 + putStr "zz" + pause + -- Line One - Extrzz + -- Line Two + + cursorForward 2 + putStr "- And More" + pause + -- Line One - Extrzz - And More + -- Line Two + + cursorDown 1 + putStr "Disconnected" + pause + -- Line One - Extrzz - And More + -- Line Two Disconnected + +lineChangeExample :: IO () +lineChangeExample = do + putStrLn "Line One" + putStr "Line Two" + pause + -- Line One + -- Line Two + + cursorUpLine 1 + putStr "New Line One" + pause + -- New Line One + -- Line Two + + cursorDownLine 1 + putStr "New Line Two" + pause + -- New Line One + -- New Line Two + +setCursorPositionExample :: IO () +setCursorPositionExample = do + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 0 5 + putStr "Foo" + pause + -- Line Foo + -- Line Two + + setCursorPosition 1 5 + putStr "Bar" + pause + -- Line Foo + -- Line Bar + + setCursorColumn 1 + putStr "oaf" + pause + -- Line Foo + -- Loaf Bar + +clearExample :: IO () +clearExample = do + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 0 4 + clearFromCursorToScreenEnd + pause + -- Line + + + resetScreen + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 1 4 + clearFromCursorToScreenBeginning + pause + -- + -- Two + + + resetScreen + putStrLn "Line One" + putStrLn "Line Two" + pause + -- Line One + -- Line Two + + setCursorPosition 0 4 + clearFromCursorToLineEnd + pause + -- Line + -- Line Two + + setCursorPosition 1 4 + clearFromCursorToLineBeginning + pause + -- Line + -- Two + + clearLine + pause + -- Line + + clearScreen + pause + -- + +scrollExample :: IO () +scrollExample = do + putStrLn "Line One" + putStrLn "Line Two" + putStrLn "Line Three" + pause + -- Line One + -- Line Two + -- Line Three + + scrollPageDown 2 + pause + -- + -- + -- Line One + -- Line Two + -- Line Three + + scrollPageUp 3 + pause + -- Line Two + -- Line Three + +sgrExample :: IO () +sgrExample = do + let colors = enumFromTo minBound maxBound :: [Color] + forM_ [Foreground, Background] $ \layer -> do + forM_ [Dull, Vivid] $ \intensity -> do + resetScreen + forM_ colors $ \color -> do + setSGR [Reset] + setSGR [SetColor layer intensity color] + putStrLn (show color) + pause + -- All the colors, 4 times in sequence + + let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") + , (SetConsoleIntensity FaintIntensity, "Faint") + , (SetConsoleIntensity NormalIntensity, "Normal") + , (SetItalicized True, "Italic") + , (SetItalicized False, "No Italics") + , (SetUnderlining SingleUnderline, "Single Underline") + , (SetUnderlining DoubleUnderline, "Double Underline") + , (SetUnderlining NoUnderline, "No Underline") + , (SetBlinkSpeed SlowBlink, "Slow Blink") + , (SetBlinkSpeed RapidBlink, "Rapid Blink") + , (SetBlinkSpeed NoBlink, "No Blink") + , (SetVisible False, "Conceal") + , (SetVisible True, "Reveal") + ] + forM_ named_styles $ \(style, name) -> do + resetScreen + setSGR [style] + putStrLn name + pause + -- Text describing a style displayed in that style in sequence + + setSGR [SetColor Foreground Vivid Red] + setSGR [SetColor Background Vivid Blue] + + clearScreen >> setCursorPosition 0 0 + setSGR [SetSwapForegroundBackground False] + putStr "Red-On-Blue" + pause + -- Red-On-Blue + + clearScreen >> setCursorPosition 0 0 + setSGR [SetSwapForegroundBackground True] + putStr "Blue-On-Red" + pause + -- Blue-On-Red + +cursorVisibilityExample :: IO () +cursorVisibilityExample = do + putStr "Cursor Demo" + pause + -- Cursor Demo| + + hideCursor + pause + -- Cursor Demo + + showCursor + pause + -- Cursor Demo| + +titleExample :: IO () +titleExample = do + putStr "Title Demo" + pause + -- ~/foo/ - ansi-terminal-ex - 83x70 + ------------------------------------ + -- Title Demo + + setTitle "Yup, I'm a new title!" + pause + -- Yup, I'm a new title! - ansi-terminal-ex - 83x70 + --------------------------------------------------- + -- Title Demo \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Unix.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Unix.hs new file mode 100644 index 0000000..eaece69 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Unix.hs @@ -0,0 +1,125 @@ +{-# OPTIONS_HADDOCK hide #-} +module System.Console.ANSI.Unix ( +#include "Exports-Include.hs" + ) where + +import System.Console.ANSI.Common + +import System.IO + +import Data.List + + +#include "Common-Include.hs" + + +-- | The reference I used for the ANSI escape characters in this module was . +csi :: [Int] -> String -> String +csi args code = "\ESC[" ++ concat (intersperse ";" (map show args)) ++ code + +colorToCode :: Color -> Int +colorToCode color = case color of + Black -> 0 + Red -> 1 + Green -> 2 + Yellow -> 3 + Blue -> 4 + Magenta -> 5 + Cyan -> 6 + White -> 7 + +sgrToCode :: SGR -> Int +sgrToCode sgr = case sgr of + Reset -> 0 + SetConsoleIntensity intensity -> case intensity of + BoldIntensity -> 1 + FaintIntensity -> 2 + NormalIntensity -> 22 + SetItalicized True -> 3 + SetItalicized False -> 23 + SetUnderlining underlining -> case underlining of + SingleUnderline -> 4 + DoubleUnderline -> 21 + NoUnderline -> 24 + SetBlinkSpeed blink_speed -> case blink_speed of + SlowBlink -> 5 + RapidBlink -> 6 + NoBlink -> 25 + SetVisible False -> 8 + SetVisible True -> 28 + SetSwapForegroundBackground True -> 7 + SetSwapForegroundBackground False -> 27 + SetColor Foreground Dull color -> 30 + colorToCode color + SetColor Foreground Vivid color -> 90 + colorToCode color + SetColor Background Dull color -> 40 + colorToCode color + SetColor Background Vivid color -> 100 + colorToCode color + + +cursorUpCode n = csi [n] "A" +cursorDownCode n = csi [n] "B" +cursorForwardCode n = csi [n] "C" +cursorBackwardCode n = csi [n] "D" + +hCursorUp h n = hPutStr h $ cursorUpCode n +hCursorDown h n = hPutStr h $ cursorDownCode n +hCursorForward h n = hPutStr h $ cursorForwardCode n +hCursorBackward h n = hPutStr h $ cursorBackwardCode n + + +cursorDownLineCode n = csi [n] "E" +cursorUpLineCode n = csi [n] "F" + +hCursorDownLine h n = hPutStr h $ cursorDownLineCode n +hCursorUpLine h n = hPutStr h $ cursorUpLineCode n + + +setCursorColumnCode n = csi [n + 1] "G" +setCursorPositionCode n m = csi [n + 1, m + 1] "H" + +hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n +hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m + + +clearFromCursorToScreenEndCode = csi [0] "J" +clearFromCursorToScreenBeginningCode = csi [1] "J" +clearScreenCode = csi [2] "J" + +hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode +hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode +hClearScreen h = hPutStr h clearScreenCode + + +clearFromCursorToLineEndCode = csi [0] "K" +clearFromCursorToLineBeginningCode = csi [1] "K" +clearLineCode = csi [2] "K" + +hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode +hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode +hClearLine h = hPutStr h clearLineCode + + +scrollPageUpCode n = csi [n] "S" +scrollPageDownCode n = csi [n] "T" + +hScrollPageUp h n = hPutStr h $ scrollPageUpCode n +hScrollPageDown h n = hPutStr h $ scrollPageDownCode n + + +setSGRCode sgrs = csi (map sgrToCode sgrs) "m" + +hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs + + +hideCursorCode = csi [] "?25l" +showCursorCode = csi [] "?25h" + +hHideCursor h = hPutStr h hideCursorCode +hShowCursor h = hPutStr h showCursorCode + + +-- | Thanks to Brandon S. Allbery and Curt Sampson for pointing me in the right direction on xterm title setting on haskell-cafe. +-- The "0" signifies that both the title and "icon" text should be set: i.e. the text for the window in the Start bar (or similar) +-- as well as that in the actual window title. This is chosen for consistent behaviour between Unixes and Windows. +setTitleCode title = "\ESC]0;" ++ filter (/= '\007') title ++ "\007" + +hSetTitle h title = hPutStr h $ setTitleCode title \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows.hs new file mode 100644 index 0000000..2a823d2 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_HADDOCK hide #-} +module System.Console.ANSI.Windows ( +#include "Exports-Include.hs" + ) where + +import System.Console.ANSI.Common +import System.Console.ANSI.Windows.Emulator diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows/Emulator.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows/Emulator.hs new file mode 100644 index 0000000..7bf3cbb --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows/Emulator.hs @@ -0,0 +1,254 @@ +module System.Console.ANSI.Windows.Emulator ( +#include "Exports-Include.hs" + ) where + +import System.Console.ANSI.Common +import qualified System.Console.ANSI.Unix as Unix +import System.Console.ANSI.Windows.Foreign + +import System.IO + +import Control.Exception (SomeException, catchJust) +import Control.Monad (guard) + +import Data.Bits +import Data.Char (toLower) +import Data.List + + +#include "Common-Include.hs" + + +withHandle :: Handle -> (HANDLE -> IO a) -> IO a +withHandle handle action = do + -- It's VERY IMPORTANT that we flush before issuing any sort of Windows API call to change the console + -- because on Windows the arrival of API-initiated state changes is not necessarily synchronised with that + -- of the text they are attempting to modify. + hFlush handle + withHandleToHANDLE handle action + + +-- Unfortunately, the emulator is not perfect. In particular, it has a tendency to die with exceptions about +-- invalid handles when it is used with certain Windows consoles (e.g. mintty, terminator, or cygwin sshd). +-- +-- This happens because in those environments the stdout family of handles are not actually associated with +-- a real console. +-- +-- My observation is that every time I've seen this in practice, the handle we have instead of the actual console +-- handle is there so that the terminal supports ANSI escape codes. So 99% of the time, the correct thing to do is +-- just to fall back on the Unix module to output the ANSI codes and hope for the best. +emulatorFallback :: IO a -> IO a -> IO a +emulatorFallback fallback first_try = catchJust (\e -> guard (isHandleIsInvalidException e) >> return ()) first_try (\() -> fallback) + where + -- NB: this is a pretty hacked-up way to find out if we have the right sort of exception, but System.Win32.Types.fail* call into + -- the fail :: String -> IO a function, and so we don't get any nice exception object we can extract information from. + isHandleIsInvalidException :: SomeException -> Bool + isHandleIsInvalidException e = "the handle is invalid" `isInfixOf` e_string || "invalid handle" `isInfixOf` e_string + where e_string = map toLower (show e) + + +adjustCursorPosition :: HANDLE -> (SHORT -> SHORT -> SHORT) -> (SHORT -> SHORT -> SHORT) -> IO () +adjustCursorPosition handle change_x change_y = do + screen_buffer_info <- getConsoleScreenBufferInfo handle + let window = csbi_window screen_buffer_info + (COORD x y) = csbi_cursor_position screen_buffer_info + cursor_pos' = COORD (change_x (rect_left window) x) (change_y (rect_top window) y) + setConsoleCursorPosition handle cursor_pos' + +hCursorUp h n = emulatorFallback (Unix.hCursorUp h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x) (\_ y -> y - fromIntegral n) +hCursorDown h n = emulatorFallback (Unix.hCursorDown h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x) (\_ y -> y + fromIntegral n) +hCursorForward h n = emulatorFallback (Unix.hCursorForward h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x + fromIntegral n) (\_ y -> y) +hCursorBackward h n = emulatorFallback (Unix.hCursorBackward h n) $ withHandle h $ \handle -> adjustCursorPosition handle (\_ x -> x - fromIntegral n) (\_ y -> y) + +cursorUpCode _ = "" +cursorDownCode _ = "" +cursorForwardCode _ = "" +cursorBackwardCode _ = "" + + +adjustLine :: HANDLE -> (SHORT -> SHORT -> SHORT) -> IO () +adjustLine handle change_y = adjustCursorPosition handle (\window_left _ -> window_left) change_y + +hCursorDownLine h n = emulatorFallback (Unix.hCursorDownLine h n) $ withHandle h $ \handle -> adjustLine handle (\_ y -> y + fromIntegral n) +hCursorUpLine h n = emulatorFallback (Unix.hCursorUpLine h n) $ withHandle h $ \handle -> adjustLine handle (\_ y -> y - fromIntegral n) + +cursorDownLineCode _ = "" +cursorUpLineCode _ = "" + + +hSetCursorColumn h x = emulatorFallback (Unix.hSetCursorColumn h x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\_ y -> y) + +setCursorColumnCode _ = "" + + +hSetCursorPosition h y x = emulatorFallback (Unix.hSetCursorPosition h y x) $ withHandle h $ \handle -> adjustCursorPosition handle (\window_left _ -> window_left + fromIntegral x) (\window_top _ -> window_top + fromIntegral y) + +setCursorPositionCode _ _ = "" + + +clearChar :: WCHAR +clearChar = charToWCHAR ' ' + +clearAttribute :: WORD +clearAttribute = 0 + +hClearScreenFraction :: HANDLE -> (SMALL_RECT -> COORD -> (DWORD, COORD)) -> IO () +hClearScreenFraction handle fraction_finder = do + screen_buffer_info <- getConsoleScreenBufferInfo handle + + let window = csbi_window screen_buffer_info + cursor_pos = csbi_cursor_position screen_buffer_info + (fill_length, fill_cursor_pos) = fraction_finder window cursor_pos + + fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos + fillConsoleOutputAttribute handle clearAttribute fill_length fill_cursor_pos + return () + +hClearFromCursorToScreenEnd h = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go + where + go window cursor_pos = (fromIntegral fill_length, cursor_pos) + where + size_x = rect_width window + size_y = rect_bottom window - coord_y cursor_pos + line_remainder = size_x - coord_x cursor_pos + fill_length = size_x * size_y + line_remainder + +hClearFromCursorToScreenBeginning h = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go + where + go window cursor_pos = (fromIntegral fill_length, rect_top_left window) + where + size_x = rect_width window + size_y = coord_y cursor_pos - rect_top window + line_remainder = coord_x cursor_pos + fill_length = size_x * size_y + line_remainder + +hClearScreen h = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ \handle -> hClearScreenFraction handle go + where + go window _ = (fromIntegral fill_length, rect_top_left window) + where + size_x = rect_width window + size_y = rect_height window + fill_length = size_x * size_y + +hClearFromCursorToLineEnd h = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go + where + go window cursor_pos = (fromIntegral (rect_right window - coord_x cursor_pos), cursor_pos) + +hClearFromCursorToLineBeginning h = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go + where + go window cursor_pos = (fromIntegral (coord_x cursor_pos), cursor_pos { coord_x = rect_left window }) + +hClearLine h = emulatorFallback (Unix.hClearLine h) $ withHandle h $ \handle -> hClearScreenFraction handle go + where + go window cursor_pos = (fromIntegral (rect_width window), cursor_pos { coord_x = rect_left window }) + +clearFromCursorToScreenEndCode = "" +clearFromCursorToScreenBeginningCode = "" +clearScreenCode = "" +clearFromCursorToLineEndCode = "" +clearFromCursorToLineBeginningCode = "" +clearLineCode = "" + + +hScrollPage :: HANDLE -> Int -> IO () +hScrollPage handle new_origin_y = do + screen_buffer_info <- getConsoleScreenBufferInfo handle + let fill = CHAR_INFO clearChar clearAttribute + window = csbi_window screen_buffer_info + origin = COORD (rect_left window) (rect_top window + fromIntegral new_origin_y) + scrollConsoleScreenBuffer handle window Nothing origin fill + +hScrollPageUp h n = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ \handle -> hScrollPage handle (negate n) +hScrollPageDown h n = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ \handle -> hScrollPage handle n + +scrollPageUpCode _ = "" +scrollPageDownCode _ = "" + + +{-# INLINE applyANSIColorToAttribute #-} +applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD +applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of + Black -> attribute' + Red -> attribute' .|. rED + Green -> attribute' .|. gREEN + Yellow -> attribute' .|. rED .|. gREEN + Blue -> attribute' .|. bLUE + Magenta -> attribute' .|. rED .|. bLUE + Cyan -> attribute' .|. gREEN .|. bLUE + White -> attribute' .|. wHITE + where + wHITE = rED .|. gREEN .|. bLUE + attribute' = attribute .&. (complement wHITE) + +applyForegroundANSIColorToAttribute, applyBackgroundANSIColorToAttribute :: Color -> WORD -> WORD +applyForegroundANSIColorToAttribute = applyANSIColorToAttribute fOREGROUND_RED fOREGROUND_GREEN fOREGROUND_BLUE +applyBackgroundANSIColorToAttribute = applyANSIColorToAttribute bACKGROUND_RED bACKGROUND_GREEN bACKGROUND_BLUE + +swapForegroundBackgroundColors :: WORD -> WORD +swapForegroundBackgroundColors attribute = clean_attribute .|. foreground_attribute' .|. background_attribute' + where + foreground_attribute = attribute .&. fOREGROUND_INTENSE_WHITE + background_attribute = attribute .&. bACKGROUND_INTENSE_WHITE + clean_attribute = attribute .&. complement (fOREGROUND_INTENSE_WHITE .|. bACKGROUND_INTENSE_WHITE) + foreground_attribute' = background_attribute `shiftR` 4 + background_attribute' = foreground_attribute `shiftL` 4 + +applyANSISGRToAttribute :: SGR -> WORD -> WORD +applyANSISGRToAttribute sgr attribute = case sgr of + Reset -> fOREGROUND_WHITE + SetConsoleIntensity intensity -> case intensity of + BoldIntensity -> attribute .|. iNTENSITY + FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported + NormalIntensity -> attribute .&. (complement iNTENSITY) + SetItalicized _ -> attribute -- Not supported + SetUnderlining underlining -> case underlining of + NoUnderline -> attribute .&. (complement cOMMON_LVB_UNDERSCORE) + _ -> attribute .|. cOMMON_LVB_UNDERSCORE -- Not supported, since cOMMON_LVB_UNDERSCORE seems to have no effect + SetBlinkSpeed _ -> attribute -- Not supported + SetVisible _ -> attribute -- Not supported + -- The cOMMON_LVB_REVERSE_VIDEO doesn't actually appear to have any affect on the colors being displayed, so the emulator + -- just uses it to carry information and implements the color-swapping behaviour itself. Bit of a hack, I guess :-) + SetSwapForegroundBackground True -> + -- Check if the color-swapping flag is already set + if attribute .&. cOMMON_LVB_REVERSE_VIDEO /= 0 + then attribute + else swapForegroundBackgroundColors attribute .|. cOMMON_LVB_REVERSE_VIDEO + SetSwapForegroundBackground False -> + -- Check if the color-swapping flag is already not set + if attribute .&. cOMMON_LVB_REVERSE_VIDEO == 0 + then attribute + else swapForegroundBackgroundColors attribute .&. (complement cOMMON_LVB_REVERSE_VIDEO) + SetColor Foreground Dull color -> applyForegroundANSIColorToAttribute color (attribute .&. (complement fOREGROUND_INTENSITY)) + SetColor Foreground Vivid color -> applyForegroundANSIColorToAttribute color (attribute .|. fOREGROUND_INTENSITY) + SetColor Background Dull color -> applyBackgroundANSIColorToAttribute color (attribute .&. (complement bACKGROUND_INTENSITY)) + SetColor Background Vivid color -> applyBackgroundANSIColorToAttribute color (attribute .|. bACKGROUND_INTENSITY) + where + iNTENSITY = fOREGROUND_INTENSITY .|. bACKGROUND_INTENSITY + +hSetSGR h sgr = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do + screen_buffer_info <- getConsoleScreenBufferInfo handle + let attribute = csbi_attributes screen_buffer_info + attribute' = foldl' (flip applyANSISGRToAttribute) attribute sgr + setConsoleTextAttribute handle attribute' + +setSGRCode _ = "" + + +hChangeCursorVisibility :: HANDLE -> Bool -> IO () +hChangeCursorVisibility handle cursor_visible = do + cursor_info <- getConsoleCursorInfo handle + setConsoleCursorInfo handle (cursor_info { cci_cursor_visible = cursor_visible }) + +hHideCursor h = emulatorFallback (Unix.hHideCursor h) $ withHandle h $ \handle -> hChangeCursorVisibility handle False +hShowCursor h = emulatorFallback (Unix.hShowCursor h) $ withHandle h $ \handle -> hChangeCursorVisibility handle True + +hideCursorCode = "" +showCursorCode = "" + + +-- Windows only supports setting the terminal title on a process-wide basis, so for now we will +-- assume that that is what the user intended. This will fail if they are sending the command +-- over e.g. a network link... but that's not really what I'm designing for. +hSetTitle h title = emulatorFallback (Unix.hSetTitle h title) $ withTString title $ setConsoleTitle + +setTitleCode _ = "" diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows/Foreign.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows/Foreign.hs new file mode 100644 index 0000000..adacbab --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/System/Console/ANSI/Windows/Foreign.hs @@ -0,0 +1,323 @@ +-- | "System.Win32.Console" is really very impoverished, so I have had to do all the FFI myself. +module System.Console.ANSI.Windows.Foreign ( + -- Re-exports from Win32.Types + BOOL, WORD, DWORD, WCHAR, HANDLE, SHORT, + + charToWCHAR, + + COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, + CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), + + sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE, + + fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, fOREGROUND_WHITE, fOREGROUND_INTENSE_WHITE, + bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, bACKGROUND_WHITE, bACKGROUND_INTENSE_WHITE, + cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE, + + getStdHandle, + getConsoleScreenBufferInfo, + getConsoleCursorInfo, + + setConsoleTextAttribute, + setConsoleCursorPosition, + setConsoleCursorInfo, + setConsoleTitle, + + fillConsoleOutputAttribute, + fillConsoleOutputCharacter, + scrollConsoleScreenBuffer, + + withTString, withHandleToHANDLE + ) where + +import Foreign.C.Types +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable + +import Data.Bits +import Data.Char + +import System.Win32.Types + +import Control.Concurrent.MVar +import Control.Exception (bracket) + +import Foreign.StablePtr + +import GHC.IOBase (Handle(..), Handle__(..)) +import qualified GHC.IOBase as IOBase (FD) -- Just an Int32 + +#if __GLASGOW_HASKELL__ >= 612 +import GHC.IO.FD (FD(..)) -- A wrapper around an Int32 +import Data.Typeable +#endif + + +-- Some Windows types missing from System.Win32 +type SHORT = CShort +type WCHAR = CWchar + +charToWCHAR :: Char -> WCHAR +charToWCHAR char = fromIntegral (ord char) + + +-- This is a FFI hack. Some of the API calls take a Coord, but that isn't a built-in FFI type so I can't +-- use it directly. Instead, I use UNPACKED_COORD and marshal COORDs into this manually. Note that we CAN'T +-- just use two SHORTs directly because they get expanded to 4 bytes each instead of just boing 2 lots of 2 +-- bytes by the stdcall convention, so linking fails. +type UNPACKED_COORD = CInt + +-- Field packing order determined experimentally: I couldn't immediately find a specification for Windows +-- struct layout anywhere. +unpackCOORD :: COORD -> UNPACKED_COORD +unpackCOORD (COORD x y) = (fromIntegral y) `shiftL` (sizeOf x * 8) .|. (fromIntegral x) + + +peekAndOffset :: Storable a => Ptr a -> IO (a, Ptr b) +peekAndOffset ptr = do + item <- peek ptr + return (item, ptr `plusPtr` sizeOf item) + +pokeAndOffset :: Storable a => Ptr a -> a -> IO (Ptr b) +pokeAndOffset ptr item = do + poke ptr item + return (ptr `plusPtr` sizeOf item) + + +data COORD = COORD { + coord_x :: SHORT, + coord_y :: SHORT + } + +instance Show COORD where + show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")" + +instance Storable COORD where + sizeOf ~(COORD x y) = sizeOf x + sizeOf y + alignment ~(COORD x _) = alignment x + peek ptr = do + let ptr' = castPtr ptr :: Ptr SHORT + x <- peekElemOff ptr' 0 + y <- peekElemOff ptr' 1 + return (COORD x y) + poke ptr (COORD x y) = do + let ptr' = castPtr ptr :: Ptr SHORT + pokeElemOff ptr' 0 x + pokeElemOff ptr' 1 y + + +data SMALL_RECT = SMALL_RECT { + rect_top_left :: COORD, + rect_bottom_right :: COORD + } + +rect_top, rect_left, rect_bottom, rect_right :: SMALL_RECT -> SHORT +rect_top = coord_y . rect_top_left +rect_left = coord_x . rect_top_left +rect_bottom = coord_y . rect_bottom_right +rect_right = coord_x . rect_bottom_right + +rect_width, rect_height :: SMALL_RECT -> SHORT +rect_width rect = rect_right rect - rect_left rect + 1 +rect_height rect = rect_bottom rect - rect_top rect + 1 + +instance Show SMALL_RECT where + show (SMALL_RECT tl br) = show tl ++ "-" ++ show br + +instance Storable SMALL_RECT where + sizeOf ~(SMALL_RECT tl br) = sizeOf tl + sizeOf br + alignment ~(SMALL_RECT tl _) = alignment tl + peek ptr = do + let ptr' = castPtr ptr :: Ptr COORD + tl <- peekElemOff ptr' 0 + br <- peekElemOff ptr' 1 + return (SMALL_RECT tl br) + poke ptr (SMALL_RECT tl br) = do + let ptr' = castPtr ptr :: Ptr COORD + pokeElemOff ptr' 0 tl + pokeElemOff ptr' 1 br + + +data CONSOLE_CURSOR_INFO = CONSOLE_CURSOR_INFO { + cci_cursor_size :: DWORD, + cci_cursor_visible :: BOOL + } + deriving (Show) + +instance Storable CONSOLE_CURSOR_INFO where + sizeOf ~(CONSOLE_CURSOR_INFO size visible) = sizeOf size + sizeOf visible + alignment ~(CONSOLE_CURSOR_INFO size _) = alignment size + peek ptr = do + (size, ptr') <- peekAndOffset (castPtr ptr) + visible <- peek ptr' + return (CONSOLE_CURSOR_INFO size visible) + poke ptr (CONSOLE_CURSOR_INFO size visible) = do + ptr' <- pokeAndOffset (castPtr ptr) size + poke ptr' visible + + +data CONSOLE_SCREEN_BUFFER_INFO = CONSOLE_SCREEN_BUFFER_INFO { + csbi_size :: COORD, + csbi_cursor_position :: COORD, + csbi_attributes :: WORD, + csbi_window :: SMALL_RECT, + csbi_maximum_window_size :: COORD + } + deriving (Show) + +instance Storable CONSOLE_SCREEN_BUFFER_INFO where + sizeOf ~(CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) + = sizeOf size + sizeOf cursor_position + sizeOf attributes + sizeOf window + sizeOf maximum_window_size + alignment ~(CONSOLE_SCREEN_BUFFER_INFO size _ _ _ _) = alignment size + peek ptr = do + (size, ptr1) <- peekAndOffset (castPtr ptr) + (cursor_position, ptr2) <- peekAndOffset ptr1 + (attributes, ptr3) <- peekAndOffset ptr2 + (window, ptr4) <- peekAndOffset ptr3 + maximum_window_size <- peek ptr4 + return (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) + poke ptr (CONSOLE_SCREEN_BUFFER_INFO size cursor_position attributes window maximum_window_size) = do + ptr1 <- pokeAndOffset (castPtr ptr) size + ptr2 <- pokeAndOffset ptr1 cursor_position + ptr3 <- pokeAndOffset ptr2 attributes + ptr4 <- pokeAndOffset ptr3 window + poke ptr4 maximum_window_size + + +data CHAR_INFO = CHAR_INFO { + ci_char :: WCHAR, + ci_attributes :: WORD + } + deriving (Show) + +instance Storable CHAR_INFO where + sizeOf ~(CHAR_INFO char attributes) = sizeOf char + sizeOf attributes + alignment ~(CHAR_INFO char _) = alignment char + peek ptr = do + (char, ptr') <- peekAndOffset (castPtr ptr) + attributes <- peek ptr' + return (CHAR_INFO char attributes) + poke ptr (CHAR_INFO char attributes) = do + ptr' <- pokeAndOffset (castPtr ptr) char + poke ptr' attributes + + +sTD_INPUT_HANDLE, sTD_OUTPUT_HANDLE, sTD_ERROR_HANDLE :: DWORD +sTD_INPUT_HANDLE = -10 +sTD_OUTPUT_HANDLE = -11 +sTD_ERROR_HANDLE = -12 + +fOREGROUND_BLUE, fOREGROUND_GREEN, fOREGROUND_RED, fOREGROUND_INTENSITY, + bACKGROUND_BLUE, bACKGROUND_GREEN, bACKGROUND_RED, bACKGROUND_INTENSITY, + cOMMON_LVB_REVERSE_VIDEO, cOMMON_LVB_UNDERSCORE :: WORD +fOREGROUND_BLUE = 0x1 +fOREGROUND_GREEN = 0x2 +fOREGROUND_RED = 0x4 +fOREGROUND_INTENSITY = 0x8 +bACKGROUND_BLUE = 0x10 +bACKGROUND_GREEN = 0x20 +bACKGROUND_RED= 0x40 +bACKGROUND_INTENSITY = 0x80 +cOMMON_LVB_REVERSE_VIDEO = 0x4000 +cOMMON_LVB_UNDERSCORE = 0x8000 + +fOREGROUND_WHITE, bACKGROUND_WHITE, fOREGROUND_INTENSE_WHITE, bACKGROUND_INTENSE_WHITE :: WORD +fOREGROUND_WHITE = fOREGROUND_RED .|. fOREGROUND_GREEN .|. fOREGROUND_BLUE +bACKGROUND_WHITE = bACKGROUND_RED .|. bACKGROUND_GREEN .|. bACKGROUND_BLUE +fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY +bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY + + +foreign import stdcall unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE +foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL +foreign import stdcall unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL + +foreign import stdcall unsafe "windows.h SetConsoleTextAttribute" cSetConsoleTextAttribute :: HANDLE -> WORD -> IO BOOL +foreign import stdcall unsafe "windows.h SetConsoleCursorPosition" cSetConsoleCursorPosition :: HANDLE -> UNPACKED_COORD -> IO BOOL +foreign import stdcall unsafe "windows.h SetConsoleCursorInfo" cSetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL +foreign import stdcall unsafe "windows.h SetConsoleTitleW" cSetConsoleTitle :: LPCTSTR -> IO BOOL + +foreign import stdcall unsafe "windows.h FillConsoleOutputAttribute" cFillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL +foreign import stdcall unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL +foreign import stdcall unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL + + +getConsoleScreenBufferInfo :: HANDLE -> IO CONSOLE_SCREEN_BUFFER_INFO +getConsoleScreenBufferInfo handle = alloca $ \ptr_console_screen_buffer_info -> do + failIfFalse_ "getConsoleScreenBufferInfo" $ cGetConsoleScreenBufferInfo handle ptr_console_screen_buffer_info + peek ptr_console_screen_buffer_info + +getConsoleCursorInfo :: HANDLE -> IO CONSOLE_CURSOR_INFO +getConsoleCursorInfo handle = alloca $ \ptr_console_cursor_info -> do + failIfFalse_ "getConsoleCursorInfo" $ cGetConsoleCursorInfo handle ptr_console_cursor_info + peek ptr_console_cursor_info + + +setConsoleTextAttribute :: HANDLE -> WORD -> IO () +setConsoleTextAttribute handle attributes = failIfFalse_ "setConsoleTextAttribute" $ cSetConsoleTextAttribute handle attributes + +setConsoleCursorPosition :: HANDLE -> COORD -> IO () +setConsoleCursorPosition handle cursor_position = failIfFalse_ "setConsoleCursorPosition" $ cSetConsoleCursorPosition handle (unpackCOORD cursor_position) + +setConsoleCursorInfo :: HANDLE -> CONSOLE_CURSOR_INFO -> IO () +setConsoleCursorInfo handle console_cursor_info = with console_cursor_info $ \ptr_console_cursor_info -> do + failIfFalse_ "setConsoleCursorInfo" $ cSetConsoleCursorInfo handle ptr_console_cursor_info + +setConsoleTitle :: LPCTSTR -> IO () +setConsoleTitle title = failIfFalse_ "setConsoleTitle" $ cSetConsoleTitle title + + +fillConsoleOutputAttribute :: HANDLE -> WORD -> DWORD -> COORD -> IO DWORD +fillConsoleOutputAttribute handle attribute fill_length write_origin = alloca $ \ptr_chars_written -> do + failIfFalse_ "fillConsoleOutputAttribute" $ cFillConsoleOutputAttribute handle attribute fill_length (unpackCOORD write_origin) ptr_chars_written + peek ptr_chars_written + +fillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> COORD -> IO DWORD +fillConsoleOutputCharacter handle char fill_length write_origin = alloca $ \ptr_chars_written -> do + failIfFalse_ "fillConsoleOutputCharacter" $ cFillConsoleOutputCharacter handle char fill_length (unpackCOORD write_origin) ptr_chars_written + peek ptr_chars_written + +scrollConsoleScreenBuffer :: HANDLE -> SMALL_RECT -> Maybe SMALL_RECT -> COORD -> CHAR_INFO -> IO () +scrollConsoleScreenBuffer handle scroll_rectangle mb_clip_rectangle destination_origin fill + = with scroll_rectangle $ \ptr_scroll_rectangle -> + maybeWith with mb_clip_rectangle $ \ptr_clip_rectangle -> + with fill $ \ptr_fill -> + failIfFalse_ "scrollConsoleScreenBuffer" $ cScrollConsoleScreenBuffer handle ptr_scroll_rectangle ptr_clip_rectangle (unpackCOORD destination_origin) ptr_fill + + +-- This essential function comes from the C runtime system. It is certainly provided by msvcrt, and also seems to be provided by the mingw C library - hurrah! +foreign import ccall unsafe "_get_osfhandle" cget_osfhandle :: IOBase.FD -> IO HANDLE + +-- | This bit is all highly dubious. The problem is that we want to output ANSI to arbitrary Handles rather than forcing +-- people to use stdout. However, the Windows ANSI emulator needs a Windows HANDLE to work it's magic, so we need to be able +-- to extract one of those from the Haskell Handle. +-- +-- This code accomplishes this, albeit at the cost of only being compatible with GHC. +withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a +withHandleToHANDLE haskell_handle action = + -- Create a stable pointer to the Handle. This prevents the garbage collector + -- getting to it while we are doing horrible manipulations with it, and hence + -- stops it being finalized (and closed). + withStablePtr haskell_handle $ const $ do + -- Grab the write handle variable from the Handle + let write_handle_mvar = case haskell_handle of + FileHandle _ handle_mvar -> handle_mvar + DuplexHandle _ _ handle_mvar -> handle_mvar -- This is "write" MVar, we could also take the "read" one + + -- Get the FD from the algebraic data type +#if __GLASGOW_HASKELL__ < 612 + fd <- fmap haFD $ readMVar write_handle_mvar +#else + --readMVar write_handle_mvar >>= \(Handle__ { haDevice = dev }) -> print (typeOf dev) + Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev)) $ readMVar write_handle_mvar +#endif + + -- Finally, turn that (C-land) FD into a HANDLE using msvcrt + windows_handle <- cget_osfhandle fd + + -- Do what the user originally wanted + action windows_handle + +withStablePtr :: a -> (StablePtr a -> IO b) -> IO b +withStablePtr value = bracket (newStablePtr value) freeStablePtr \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/TODO b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/TODO new file mode 100644 index 0000000..9805d30 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/TODO @@ -0,0 +1,7 @@ +=== High Priority === + +=== Medium Priority === + +=== Low Priority === +* Detect use of handles that are not console handles and raise some error? I'm currently falling back on ANSI, which may not be ideal. +* Provide API for hiding cursor in a region of IO using installHandler \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/ansi-terminal.cabal b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/ansi-terminal.cabal new file mode 100644 index 0000000..1f12715 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/ansi-terminal.cabal @@ -0,0 +1,88 @@ +Name: ansi-terminal +Version: 0.6 +Cabal-Version: >= 1.2 +Category: User Interfaces +Synopsis: Simple ANSI terminal support, with Windows compatibility +Description: ANSI terminal support for Haskell: allows cursor movement, screen clearing, color output showing or hiding the cursor, and + changing the title. Compatible with Windows and those Unixes with ANSI terminals, but only GHC is supported as a compiler. +License: BSD3 +License-File: LICENSE +Extra-Source-Files: README.textile +Author: Max Bolingbroke +Maintainer: batterseapower@hotmail.com +Homepage: http://batterseapower.github.com/ansi-terminal +Build-Type: Simple + +Extra-Source-Files: includes/Common-Include.hs + includes/Exports-Include.hs + +Flag SplitBase + Description: Choose the new smaller, split-up base package + Default: True + +Flag Example + Description: Build the example application + Default: False + +Library + Exposed-Modules: System.Console.ANSI + + Other-Modules: System.Console.ANSI.Common + + Include-Dirs: includes + + if os(windows) + Build-Depends: Win32 >= 2.0 + Cpp-Options: -DWINDOWS + Extra-Libraries: "kernel32" + Other-Modules: System.Console.ANSI.Windows + System.Console.ANSI.Windows.Foreign + System.Console.ANSI.Windows.Emulator + -- NB: used for fallback by the emulator + System.Console.ANSI.Unix + else + -- We assume any non-Windows platform is Unix + Build-Depends: unix >= 2.3.0.0 + Cpp-Options: -DUNIX + Other-Modules: System.Console.ANSI.Unix + + if flag(splitBase) + Build-Depends: base >= 3 && < 5 + else + Build-Depends: base < 3 + + Extensions: CPP + ForeignFunctionInterface + + Ghc-Options: -Wall + +Executable ansi-terminal-example + Main-Is: System/Console/ANSI/Example.hs + + Cpp-Options: -Iincludes + + if os(windows) + Build-Depends: Win32 >= 2.0 + Cpp-Options: -DWINDOWS + Extra-Libraries: "kernel32" + Other-Modules: System.Console.ANSI.Windows + System.Console.ANSI.Windows.Foreign + System.Console.ANSI.Windows.Emulator + else + -- We assume any non-Windows platform is Unix + Build-Depends: unix >= 2.3.0.0 + Cpp-Options: -DUNIX + Other-Modules: System.Console.ANSI.Unix + + if flag(splitBase) + Build-Depends: base >= 3 && < 5 + else + Build-Depends: base < 3 + + Extensions: CPP + ForeignFunctionInterface + + Ghc-Options: -Wall + + if !flag(example) + Buildable: False diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/includes/Common-Include.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/includes/Common-Include.hs new file mode 100644 index 0000000..ce8ad67 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/includes/Common-Include.hs @@ -0,0 +1,127 @@ +hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: Handle + -> Int -- ^ Number of lines or characters to move + -> IO () +cursorUp, cursorDown, cursorForward, cursorBackward :: Int -- ^ Number of lines or characters to move + -> IO () +cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode :: Int -- ^ Number of lines or characters to move + -> String + +cursorUp = hCursorUp stdout +cursorDown = hCursorDown stdout +cursorForward = hCursorForward stdout +cursorBackward = hCursorBackward stdout + + +hCursorDownLine, hCursorUpLine :: Handle + -> Int -- ^ Number of lines to move + -> IO () +cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move + -> IO () +cursorDownLineCode, cursorUpLineCode :: Int -- ^ Number of lines to move + -> String + +cursorDownLine = hCursorDownLine stdout +cursorUpLine = hCursorUpLine stdout + + +hSetCursorColumn :: Handle + -> Int -- ^ 0-based column to move to + -> IO () +setCursorColumn :: Int -- ^ 0-based column to move to + -> IO () +setCursorColumnCode :: Int -- ^ 0-based column to move to + -> String + +setCursorColumn = hSetCursorColumn stdout + + +hSetCursorPosition :: Handle + -> Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPosition :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> IO () +setCursorPositionCode :: Int -- ^ 0-based row to move to + -> Int -- ^ 0-based column to move to + -> String + +setCursorPosition = hSetCursorPosition stdout + + +hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: Handle + -> IO () +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO () +clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String + +clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout +clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout +clearScreen = hClearScreen stdout + + +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: Handle + -> IO () +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO () +clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String + +clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout +clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout +clearLine = hClearLine stdout + + +-- | Scroll the displayed information up or down the terminal: not widely supported +hScrollPageUp, hScrollPageDown :: Handle + -> Int -- ^ Number of lines to scroll by + -> IO () +-- | Scroll the displayed information up or down the terminal: not widely supported +scrollPageUp, scrollPageDown :: Int -- ^ Number of lines to scroll by + -> IO () +-- | Scroll the displayed information up or down the terminal: not widely supported +scrollPageUpCode, scrollPageDownCode :: Int -- ^ Number of lines to scroll by + -> String + +scrollPageUp = hScrollPageUp stdout +scrollPageDown = hScrollPageDown stdout + + +-- | Set the Select Graphic Rendition mode +hSetSGR :: Handle + -> [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. + -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied + -- left to right. + -> IO () +-- | Set the Select Graphic Rendition mode +setSGR :: [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. + -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied + -- left to right. + -> IO () +-- | Set the Select Graphic Rendition mode +setSGRCode :: [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode. + -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied + -- left to right. + -> String + +setSGR = hSetSGR stdout + + +hHideCursor, hShowCursor :: Handle + -> IO () +hideCursor, showCursor :: IO () +hideCursorCode, showCursorCode :: String + +hideCursor = hHideCursor stdout +showCursor = hShowCursor stdout + + +-- | Set the terminal window title +hSetTitle :: Handle + -> String -- ^ New title + -> IO () +-- | Set the terminal window title +setTitle :: String -- ^ New title + -> IO () +-- | Set the terminal window title +setTitleCode :: String -- ^ New title + -> String + +setTitle = hSetTitle stdout \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/includes/Exports-Include.hs b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/includes/Exports-Include.hs new file mode 100644 index 0000000..b134d74 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/includes/Exports-Include.hs @@ -0,0 +1,50 @@ +-- * Basic data types +module System.Console.ANSI.Common, + +-- * Cursor movement by character +cursorUp, cursorDown, cursorForward, cursorBackward, +hCursorUp, hCursorDown, hCursorForward, hCursorBackward, +cursorUpCode, cursorDownCode, cursorForwardCode, cursorBackwardCode, + +-- * Cursor movement by line +cursorUpLine, cursorDownLine, +hCursorUpLine, hCursorDownLine, +cursorUpLineCode, cursorDownLineCode, + +-- * Directly changing cursor position +setCursorColumn, +hSetCursorColumn, +setCursorColumnCode, + +setCursorPosition, +hSetCursorPosition, +setCursorPositionCode, + +-- * Clearing parts of the screen +clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen, +hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen, +clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode, + +clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine, +hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine, +clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode, + +-- * Scrolling the screen +scrollPageUp, scrollPageDown, +hScrollPageUp, hScrollPageDown, +scrollPageUpCode, scrollPageDownCode, + +-- * Select Graphic Rendition mode: colors and other whizzy stuff +setSGR, +hSetSGR, +setSGRCode, + +-- * Cursor visibilty changes +hideCursor, showCursor, +hHideCursor, hShowCursor, +hideCursorCode, showCursorCode, + +-- * Changing the title +setTitle, +hSetTitle, +setTitleCode \ No newline at end of file diff --git a/paradigma-funcional/batterseapower-ansi-terminal-57294e4/release b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/release new file mode 100755 index 0000000..1eb8357 --- /dev/null +++ b/paradigma-funcional/batterseapower-ansi-terminal-57294e4/release @@ -0,0 +1,62 @@ +#!/bin/bash +# + +echo "Have you updated the version number? Type 'yes' if you have!" +read version_response + +if [ "$version_response" != "yes" ]; then + echo "Go and update the version number" + exit 1 +fi + +sdist_output=`runghc Setup.lhs sdist` + +if [ "$?" != "0" ]; then + echo "Cabal sdist failed, aborting" + exit 1 +fi + +# Want to find a line like: +# Source tarball created: dist/ansi-terminal-0.1.tar.gz + +# Test this with: +# runghc Setup.lhs sdist | grep ... +filename=`echo $sdist_output | sed 's/.*Source tarball created: \([^ ]*\).*/\1/'` +echo "Filename: $filename" + +if [ "$filename" = "$sdist_output" ]; then + echo "Could not find filename, aborting" + exit 1 +fi + +# Test this with: +# echo dist/ansi-terminal-0.1.tar.gz | sed ... +version=`echo $filename | sed 's/^[^0-9]*\([0-9\.]*\).tar.gz$/\1/'` +echo "Version: $version" + +if [ "$version" = "$filename" ]; then + echo "Could not find version, aborting" + exit 1 +fi + +echo "This is your last chance to abort! I'm going to upload in 10 seconds" +sleep 10 + +git tag "v$version" + +if [ "$?" != "0" ]; then + echo "Git tag failed, aborting" + exit 1 +fi + +# You need to have stored your Hackage username and password as directed by cabal-upload +# I use -v3 because otherwise the error messages can be cryptic :-) +cabal upload -v3 $filename + +if [ "$?" != "0" ]; then + echo "Hackage upload failed, aborting" + exit 1 +fi + +# Success! +exit 0 diff --git a/paradigma-funcional/functions.hs b/paradigma-funcional/functions.hs index b02147c..a4df11e 100644 --- a/paradigma-funcional/functions.hs +++ b/paradigma-funcional/functions.hs @@ -60,4 +60,63 @@ setBonus gamer kind value = typeWord = typeWord gamer, synonyms = synonyms gamer, syllables = value - } \ No newline at end of file + } + +--Parametros: Nome do nivel atual +--Retorno: Pontos a adicionar +add_points :: Level -> Int +add_points level | (name level) == "PYTHON" = 20 + |(name level) == "JAVA" = 30 + |otherwise = 50 + + +--Parametros: Numero de rounds +--Retorno: Nivel atual +set_level:: Int -> String +set_level round |round <= 3 = "PYTHON" + |round >= 4 && round <= 6 = "JAVA" + |otherwise = "ASSEMBLY" + +--Parametros: Nome do nivel atual +--Retorno: Vidas a adicionar +add_lifes:: Level -> Int +add_lifes level |(name level) == "PYTHON" = 7 + |(name level) == "JAVA" = 5 + |otherwise = 3 + +--Parametros: Nome do nivel atual, pontos do jogador perdedor +--Retorno: Pontos a transferir +transfer_points:: Level -> Player -> Float +transfer_points level loser_player |(name level) == "PYTHON" = fromIntegral (points loser_player) * 0.1 + |(name level) == "JAVA" = fromIntegral (points loser_player) * 0.15 + |otherwise = fromIntegral (points loser_player) * 0.2 + +--Parametros: Nome do nivel atual +--Retorno: Tupla com vidas a diminuir e penalidade de pontos do jogador (nessa ordem) +penalize_player:: Level -> (Int, Int) +penalize_player level |(name level) == "PYTHON" = (1, 2) + |(name level) == "JAVA" = (1, 5) + |otherwise = (1, 8) + + +inicialize_menu :: String +inicialize_menu = "===========================================================\n" ++ + "| ,FORCA, RODA jequiti A RODA |\n" ++ + "===========================================================\n" ++ + "--------------------- COMO FUNCIONA -----------------------\n\n" ++ + "1 - DOIS JOGADORES APRESENTAM X CHANCES CADA UM POR RODADA \n" ++ + " PARA ADIVINHAR UMA PALAVRA ALEATORIA LETRA A LETRA.\n\n" ++ + "2 - CADA LETRA ERRADA, DEBITA PONTOS NA QUANTIDADE \n" ++ + " DETERMINADA PELO NIVEL (PYTHON, JAVA E ASSEMBLY).\n\n" ++ + "3 - QUANTO FALTAR 40% DA PALAVRA EM QUESTAO, O JOGADOR SERA\n" ++ + " SOLICITADO A DAR A RESPOSTA CORRETA. EM CASO DE ERRO, O\n" ++ + " JOGADOR SOFRERA AS PUNICOES JA CITADAS.\n\n" ++ + "4 - O JOGADOR QUE ACERTAR RECEBERÁ X PONTOS.\n\n" ++ + "5 - ZERADA AS CHANCES, O PERDEDOR AGUARDA O FINAL DA RODADA,\n" ++ + " PODENDO O ADVERSARIO LEVAR OS PONTOS SE ACERTAR A PALAVRA.\n\n" ++ + "6 - UMA NOVA PALAVRA SORTEADA A CADA RODADA.\n\n" ++ + "7 - A CADA RODADA, UM BONUS PODERA SER SOLICIDADO UMA UNICA\n" ++ + " VEZ(TIPO DA PALAVRA, PALAVRA SEMELHANTE E NUMERO DE SILABA).\n\n" ++ + "8 - AO FINAL DO JOGO, SERA O VENCEDOR AQUELE QUE ACUMULOU \n" ++ + " MAIS PONTOS.\n\n" ++ + " Pressione enter para continuar\n" \ No newline at end of file