├── .gitignore ├── LICENSE ├── README.md ├── data ├── FreeMono.ttf ├── colors.sh ├── fonts │ └── monofur │ │ ├── monof55.ttf │ │ ├── monof56.ttf │ │ └── monof_tt.txt └── init.sh ├── doc ├── screenshot_cmatrix.png ├── screenshot_htop.png └── screenshot_tig.png ├── src ├── Hsterm │ ├── Config.hs │ ├── Hsterm.hs │ ├── Main.hs │ ├── ShaderUtils.hs │ ├── State.hs │ └── Theme.hs ├── Hstermplay │ └── Main.hs └── Terminal │ ├── Debug.hs │ ├── Parser.hs │ ├── ParserUtils.hs │ ├── Terminal.hs │ └── Types.hs ├── terminal.cabal ├── tests ├── parser │ └── Main.hs └── terminal │ └── Main.hs └── themes └── default ├── background.frag ├── background.vert ├── cursor.frag └── cursor.vert /.gitignore: -------------------------------------------------------------------------------- 1 | *.sw? 2 | dist 3 | hsterm 4 | *~ 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 5 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Lesser General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Haskell terminal emulator 2 | ========================= 3 | 4 | This is an alpha version of a Haskell terminal emulator. It is both 5 | 6 | 1. a library that provides functions to parse VT100 character streams and that 7 | implements the ANSI terminal actions and 8 | 2. the actual terminal emulator executable (think xterm, gnome-terminal), 9 | which is currently based on OpenGL (see [screenshots](doc)) 10 | 11 | There is no release yet and this is only a work-in-progress repository. Just you know. 12 | -------------------------------------------------------------------------------- /data/FreeMono.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lordi/haskell-terminal/037a1374c3e28a9cc00f9da0ec8b2887944ab943/data/FreeMono.ttf -------------------------------------------------------------------------------- /data/colors.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # Display available ANSI (terminal) colour combinations 4 | 5 | # License: LGPLv2 6 | # Author: 7 | # http://www.pixelbeat.org/docs/terminal_colours/ 8 | # Changes: 9 | # V0.1, 24 Apr 2008, Initial release 10 | # V0.2, 30 Oct 2009, Support dash 11 | # V0.4, 17 May 2011 12 | # http://github.com/pixelb/scripts/commits/master/scripts/ansi_colours.sh 13 | 14 | e="\033[" 15 | printf "${e}1;4mf\\\\b${e}0m${e}4m none white black red \ 16 | green yellow blue magenta cyan ${e}0m\\n" 17 | 18 | rows='brgybmcw' 19 | 20 | for f in 0 7 `seq 6`; do 21 | no=""; bo=""; p="" 22 | for b in n 7 0 `seq 6`; do 23 | co="3$f"; [ $b = n ] || co="$co;4$b" 24 | no="${no}${e}${co}m ${p}${co} ${e}0m" 25 | bo="${bo}${e}1;${co}m${p}1;${co} ${e}0m" 26 | p=" " 27 | done 28 | fc=$(echo $rows | cut -c$((f+1))) 29 | printf "$fc $no\nb$fc$bo\n" 30 | done 31 | -------------------------------------------------------------------------------- /data/fonts/monofur/monof55.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lordi/haskell-terminal/037a1374c3e28a9cc00f9da0ec8b2887944ab943/data/fonts/monofur/monof55.ttf -------------------------------------------------------------------------------- /data/fonts/monofur/monof56.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lordi/haskell-terminal/037a1374c3e28a9cc00f9da0ec8b2887944ab943/data/fonts/monofur/monof56.ttf -------------------------------------------------------------------------------- /data/fonts/monofur/monof_tt.txt: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------ 2 | The monofur typeface by tobias b koehler (unci@tigerden.com) 3 | ------------------------------------------------------------------------ 4 | 5 | This is a monospaced geometric rounded sans serif font based on the 6 | eurofurence typeface family. 7 | 8 | The character set includes Roman, Greek and Cyrillic characters as well 9 | as box drawing characters. File format is TrueType for PC (under 10 | Windows, Linux etc). 11 | 12 | These fonts are freeware and can be distributed as long as they are 13 | together with this text file. I would appreciate it though if you could 14 | contact me at unci@tigerden.com if you put them on a server. Free 15 | samples from commercial users are always very welcome. :) 16 | 17 | For more information, please see the uncifonts WWW page at: 18 | http://mercurio.iet.unipi.it/users/tobias/uncifonts.html 19 | 20 | Have fun! tobias b koehler, 2000-04-02 -------------------------------------------------------------------------------- /data/init.sh: -------------------------------------------------------------------------------- 1 | stty echo 2 | bash data/colors.sh 3 | -------------------------------------------------------------------------------- /doc/screenshot_cmatrix.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lordi/haskell-terminal/037a1374c3e28a9cc00f9da0ec8b2887944ab943/doc/screenshot_cmatrix.png -------------------------------------------------------------------------------- /doc/screenshot_htop.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lordi/haskell-terminal/037a1374c3e28a9cc00f9da0ec8b2887944ab943/doc/screenshot_htop.png -------------------------------------------------------------------------------- /doc/screenshot_tig.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lordi/haskell-terminal/037a1374c3e28a9cc00f9da0ec8b2887944ab943/doc/screenshot_tig.png -------------------------------------------------------------------------------- /src/Hsterm/Config.hs: -------------------------------------------------------------------------------- 1 | module Hsterm.Config where 2 | import Data.Colour.SRGB (sRGB) 3 | import Data.Colour (Colour) 4 | import Terminal.Types (TerminalColor(..)) 5 | 6 | -- These get overwritten with nicer colors in Main.hs 7 | defaultColor Black = sRGB 0 0 0 8 | defaultColor Green = sRGB 0 1 0 9 | defaultColor Yellow = sRGB 0 1 1 10 | defaultColor Blue = sRGB 0 0 1 11 | defaultColor Magenta = sRGB 1 1 0 12 | defaultColor Cyan = sRGB 1 0 1 13 | defaultColor White = sRGB 1 1 1 14 | 15 | data TerminalConfig = TerminalConfig { 16 | defaultForegroundColor :: TerminalColor, 17 | defaultBackgroundColor :: TerminalColor, 18 | cursorColor :: Colour Double, 19 | colorMap :: TerminalColor -> Colour Double, 20 | colorMapBright :: TerminalColor -> Colour Double, 21 | fontPath :: FilePath, 22 | initScriptPath :: FilePath, 23 | fontSize :: Integer 24 | } 25 | 26 | defaultTerminalConfig :: TerminalConfig 27 | defaultTerminalConfig = TerminalConfig { 28 | defaultForegroundColor = White, 29 | defaultBackgroundColor = Black, 30 | cursorColor = defaultColor White, 31 | fontPath = "data/fonts/monofur/monof55.ttf", 32 | colorMap = defaultColor, 33 | colorMapBright = defaultColor, 34 | initScriptPath = "data/init.sh", 35 | fontSize = 20 36 | } 37 | 38 | 39 | -------------------------------------------------------------------------------- /src/Hsterm/Hsterm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | module Hsterm.Hsterm where 3 | import System.Process 4 | import Data.Array.Diff 5 | import Data.IORef 6 | import Data.Char 7 | import Data.Maybe (fromJust) 8 | -- import Control.Monad 9 | import Control.Monad.State hiding (state, get, State) 10 | import System.IO 11 | 12 | import Data.Time.Clock 13 | import Data.Time.Calendar 14 | import Data.Colour.SRGB (RGB(..), toSRGB) 15 | import Data.Colour (Colour(..)) 16 | 17 | import Graphics.UI.GLUT hiding (Bool, Float, fontWidth, fontHeight, RGB) 18 | import Graphics.Rendering.OpenGL hiding (Bool, Float, get, RGB) 19 | import Graphics.Rendering.OpenGL.GL.Shaders.Uniform 20 | import Graphics.Rendering.OpenGL.GLU (perspective) 21 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects 22 | import Graphics.Rendering.OpenGL.GL.Texturing.Environments 23 | import Graphics.Rendering.FTGL (createTextureFont, renderFont, setFontFaceSize, RenderMode(..), getFontAdvance) 24 | import System.Posix.IO 25 | import System.Posix.Terminal hiding (TerminalState) 26 | import Control.Concurrent 27 | import Control.Applicative hiding (many) 28 | 29 | import Terminal.Parser (parseANSI) 30 | import Terminal.Terminal 31 | import Terminal.Types 32 | import qualified Terminal.Types as T 33 | 34 | import Hsterm.State 35 | import Hsterm.ShaderUtils 36 | import Hsterm.Config 37 | 38 | -- Constants (for now) 39 | numColumns = 80 40 | numRows = 24 41 | 42 | initDisplay = do 43 | _ <- getArgsAndInitialize 44 | initialDisplayMode $= [DoubleBuffered, RGBAMode] 45 | createWindow "Haskell terminal emulator" 46 | -- TODO clearColor $= backgroundColor 47 | 48 | glColor :: Colour Double -> Color3 GLfloat 49 | glColor c = Color3 (realToFrac r) (realToFrac g) (realToFrac b) 50 | where RGB r g b = toSRGB c 51 | 52 | unitQuad = do 53 | let texCoord2f = texCoord :: TexCoord2 GLfloat -> IO () 54 | vertex3f = vertex :: Vertex3 GLfloat -> IO () 55 | renderPrimitive Quads $ do 56 | texCoord2f (TexCoord2 1 1); vertex3f (Vertex3 (-0) (-0) 0 ) 57 | texCoord2f (TexCoord2 1 0); vertex3f (Vertex3 (-0) 1 0 ) 58 | texCoord2f (TexCoord2 0 0); vertex3f (Vertex3 1 1 0 ) 59 | texCoord2f (TexCoord2 0 1); vertex3f (Vertex3 1 (-0) 0 ) 60 | 61 | reshapeHandler state size@(Size w_ h_) = do 62 | ss@(Size w h) <- getScreenSize state 63 | viewport $= (Position 0 0, ss) 64 | matrixMode $= Projection 65 | loadIdentity 66 | ortho (0::GLdouble) (fromIntegral w) 0 (fromIntegral h) 0 1 67 | 68 | displayHandler :: State -> IO () 69 | displayHandler state = do 70 | term <- get $ terminal state 71 | 72 | clear [ColorBuffer] 73 | blend $= Enabled 74 | blendFunc $= (SrcAlpha, OneMinusSrcAlpha) 75 | 76 | matrixMode $= Modelview 0 77 | loadIdentity 78 | 79 | Just font <- get $ currentFont state 80 | fontHeight' <- get $ fontHeight state 81 | fontWidth' <- get $ fontWidth state 82 | cfg <- get $ config state 83 | 84 | 85 | let fontWidth'' = realToFrac fontWidth' 86 | fontHeight'' = realToFrac fontHeight' 87 | setColor :: Bool -> TerminalColor -> IO () 88 | setColor bright c = do color (glColor (cm cfg c)) 89 | where cm = if bright then colorMapBright else colorMap 90 | toScreenCoordinates :: Int -> Int -> Vector3 GLfloat 91 | toScreenCoordinates x y = Vector3 sx sy sz 92 | where sx = fontWidth'' * (fromIntegral x - 1) 93 | sy = fontHeight'' * fromIntegral (numRows - y) 94 | sz = 0 :: GLfloat 95 | blendQuad = 96 | preservingMatrix (scale fontWidth'' fontHeight'' 1.0 >> unitQuad) 97 | 98 | forM_ (indices $ screen term) $ \idx@(y, x) -> 99 | preservingMatrix $ do 100 | let tc = screen term ! idx 101 | translate $ toScreenCoordinates x y 102 | 103 | -- Render a quad in the background color 104 | setColor False (backgroundColor tc) 105 | blendQuad 106 | 107 | -- Render a font in the foreground color 108 | setColor (isBright tc) (foregroundColor tc) 109 | translate $ Vector3 0 (4) (0 :: GLfloat) 110 | renderFont font [character tc] All 111 | 112 | -- Cursor 113 | case (optionShowCursor term) of 114 | True -> do 115 | let (y, x) = cursorPos term 116 | translate $ toScreenCoordinates x y 117 | color $ glColor $ cursorColor cfg 118 | blendQuad 119 | _ -> return () 120 | 121 | swapBuffers 122 | 123 | runTerminal :: IORef Terminal -> Handle -> Handle -> IO () 124 | runTerminal a in_ out = 125 | forever $ do 126 | c <- (liftIO $ hGetChar out) 127 | s <- readIORef a 128 | 129 | -- Parse the input buffer for characters or ANSI sequences 130 | Right (actions, leftover) <- return $ parseANSI $ inBuffer s ++ [c] 131 | 132 | -- Apply all the actions to the terminal state 133 | forM_ actions $ \x -> modifyIORef a $ applyAction x 134 | 135 | -- Store the actions that could not be parsed as input buffer 136 | modifyIORef a $ \term -> term { inBuffer = leftover } 137 | 138 | keyboardMouseHandler hInWrite (Char c) Down modifiers position = 139 | hPutChar hInWrite c 140 | keyboardMouseHandler hInWrite chr st modifiers position = return () 141 | 142 | getScreenSize :: State -> IO Size 143 | getScreenSize state = do 144 | fontWidth' <- get $ fontWidth state 145 | fontHeight' <- get $ fontHeight state 146 | return (Size (round (fontWidth' * fromIntegral numColumns)) (round (fontHeight' * fromIntegral numRows))) 147 | 148 | runHsterm :: TerminalConfig -> IO () 149 | runHsterm cfg = do 150 | (pOutRead, pOutWrite) <- createPipe 151 | (pInRead, pInWrite) <- createPipe 152 | (pErrRead, pErrWrite) <- createPipe 153 | 154 | hInRead <- fdToHandle pInRead 155 | hInWrite <- fdToHandle pInWrite 156 | hOutRead <- fdToHandle pOutRead 157 | hOutWrite <- fdToHandle pOutWrite 158 | 159 | hSetBuffering stdin NoBuffering 160 | hSetBuffering stdout NoBuffering 161 | hSetBuffering stderr NoBuffering 162 | hSetBuffering hInRead NoBuffering 163 | hSetBuffering hInWrite NoBuffering 164 | hSetBuffering hOutRead NoBuffering 165 | hSetBuffering hOutWrite NoBuffering 166 | 167 | initDisplay 168 | state <- makeState cfg 169 | 170 | font <- createTextureFont (fontPath cfg) 171 | setFontFaceSize font (fromIntegral (fontSize cfg)) 144 172 | currentFont state $= Just font 173 | advance <- getFontAdvance font "_" 174 | fontWidth state $= advance 175 | fontHeight state $= fromIntegral (fontSize cfg) 176 | 177 | ss <- getScreenSize state 178 | windowSize $= ss 179 | 180 | displayCallback $= displayHandler state 181 | idleCallback $= Just (postRedisplay Nothing) 182 | keyboardMouseCallback $= Just (keyboardMouseHandler hInWrite) 183 | reshapeCallback $= Just (reshapeHandler state) 184 | 185 | let environment = [ 186 | ("TERM", "xterm"), 187 | ("COLUMS", "79"), 188 | ("ROWS", "24")] 189 | cmd = "script" 190 | cmdParams = ["-c", "bash --init-file " ++ (initScriptPath cfg), "-f", "/dev/null"] 191 | process <- runProcess cmd cmdParams Nothing (Just environment) 192 | (Just hInRead) (Just hOutWrite) Nothing 193 | forkIO $ runTerminal (terminal state) hInWrite hOutRead 194 | mainLoop 195 | -------------------------------------------------------------------------------- /src/Hsterm/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Hsterm.Hsterm (runHsterm) 3 | import Hsterm.Config (defaultTerminalConfig, TerminalConfig(..)) 4 | import Data.Colour.SRGB 5 | import Terminal.Types (TerminalColor(..)) 6 | 7 | myConfig = defaultTerminalConfig { 8 | colorMap = \c -> sRGB24read $ case c of 9 | Black -> "#000000" 10 | Red -> "#ff6565" 11 | Green -> "#93d44f" 12 | Yellow -> "#eab93d" 13 | Blue -> "#204a87" 14 | Magenta -> "#ce5c00" 15 | Cyan -> "#89b6e2" 16 | White -> "#cccccc", 17 | colorMapBright = \c -> sRGB24read $ case c of 18 | Black -> "#555753" 19 | Red -> "#ff8d8d" 20 | Green -> "#c8e7a8" 21 | Yellow -> "#ffc123" 22 | Blue -> "#3465a4" 23 | Magenta -> "#f57900" 24 | Cyan -> "#46a4ff" 25 | White -> "#ffffff" 26 | } 27 | 28 | main = runHsterm myConfig 29 | -------------------------------------------------------------------------------- /src/Hsterm/ShaderUtils.hs: -------------------------------------------------------------------------------- 1 | -- Utils for loading, compiling and linking GLSL shaders 2 | -- Largely taken from GLUT's Brick.hs example 3 | module Hsterm.ShaderUtils where 4 | 5 | import Prelude hiding ( sum ) 6 | import Control.Applicative 7 | import Control.Monad 8 | import Control.Exception 9 | import Data.Foldable ( Foldable, sum ) 10 | import Data.IORef 11 | import Graphics.UI.GLUT 12 | 13 | -- Make sure that GLSL is supported by the driver, either directly by the core 14 | -- or via an extension. 15 | checkGLSLSupport :: IO () 16 | checkGLSLSupport = do 17 | version <- get (majorMinor glVersion) 18 | unless (version >= (2,0)) $ do 19 | extensions <- get glExtensions 20 | unless ("GL_ARB_shading_language_100" `elem` extensions) $ 21 | ioError (userError "No GLSL support found.") 22 | 23 | readAndCompileShader :: Shader s => FilePath -> IO s 24 | readAndCompileShader filePath = do 25 | src <- readFile filePath 26 | [shader] <- genObjectNames 1 27 | shaderSource shader $= [src] 28 | compileShader shader 29 | reportErrors 30 | ok <- get (compileStatus shader) 31 | infoLog <- get (shaderInfoLog shader) 32 | unless ok $ do 33 | mapM_ putStrLn ["Notice: Loaded shader '" ++ filePath ++ "': " ++ infoLog] 34 | deleteObjectNames [shader] 35 | ioError (userError "shader compilation failed") 36 | return shader 37 | 38 | linkShaders :: [VertexShader] -> [FragmentShader] -> IO (Program) 39 | linkShaders vs fs = do 40 | [prog] <- genObjectNames 1 41 | attachedShaders prog $= (vs, fs) 42 | linkProgram prog 43 | reportErrors 44 | ok <- get (linkStatus prog) 45 | unless ok $ do 46 | infoLog <- get (programInfoLog prog) 47 | putStrLn infoLog 48 | deleteObjectNames [prog] 49 | ioError (userError "linking failed") 50 | return prog 51 | 52 | readCompileAndLink :: String -> String -> IO (Program) 53 | readCompileAndLink vspath fspath = do 54 | vs <- readAndCompileShader vspath 55 | fs <- readAndCompileShader fspath 56 | linkShaders [vs] [fs] 57 | 58 | -------------------------------------------------------------------------------- /src/Hsterm/State.hs: -------------------------------------------------------------------------------- 1 | module Hsterm.State where 2 | import Data.IORef 3 | import Graphics.Rendering.OpenGL hiding (Bool, Float) 4 | import Graphics.Rendering.OpenGL.GLU (perspective) 5 | import Graphics.Rendering.GLU.Raw 6 | import Graphics.Rendering.OpenGL.GL.FramebufferObjects 7 | import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility (glPushMatrix, glPopMatrix) 8 | import Graphics.UI.GLUT hiding (Bool, Float, Font, fontHeight, fontWidth) 9 | import Graphics.Rendering.FTGL (Font) 10 | 11 | import Data.Time.Clock (getCurrentTime) 12 | import qualified Data.Time.Clock as C 13 | 14 | import Terminal.Terminal 15 | import Terminal.Types 16 | import Hsterm.Config 17 | 18 | data State = State { 19 | terminal :: IORef Terminal, 20 | startupTime :: IORef C.UTCTime, 21 | lastKeystrokeTime :: IORef C.UTCTime, 22 | backgroundProgram :: IORef (Maybe Program), 23 | foregroundProgram :: IORef (Maybe Program), 24 | cursorProgram :: IORef (Maybe Program), 25 | currentFont :: IORef (Maybe Font), 26 | fontWidth :: IORef Float, 27 | fontHeight :: IORef Float, 28 | config :: IORef TerminalConfig 29 | } 30 | 31 | makeState :: TerminalConfig -> IO State 32 | makeState cfg = do 33 | terminal' <- newIORef defaultTerm 34 | 35 | startupTime' <- getCurrentTime >>= newIORef 36 | lastKeystrokeTime' <- getCurrentTime >>= newIORef 37 | 38 | backgroundProgram' <- newIORef Nothing 39 | foregroundProgram' <- newIORef Nothing 40 | cursorProgram' <- newIORef Nothing 41 | currentFont' <- newIORef Nothing 42 | fontWidth' <- newIORef 0.0 43 | fontHeight' <- newIORef 0.0 44 | config' <- newIORef cfg 45 | 46 | return State { 47 | terminal = terminal', 48 | 49 | startupTime = startupTime', 50 | lastKeystrokeTime = lastKeystrokeTime', 51 | 52 | backgroundProgram = backgroundProgram', 53 | foregroundProgram = foregroundProgram', 54 | cursorProgram = cursorProgram', 55 | currentFont = currentFont', 56 | fontHeight = fontHeight', 57 | fontWidth = fontWidth', 58 | config = config' 59 | } 60 | -------------------------------------------------------------------------------- /src/Hsterm/Theme.hs: -------------------------------------------------------------------------------- 1 | module Hsterm.Theme (colorize) where 2 | import Terminal.Types 3 | import Data.Maybe (fromJust) 4 | import Data.Colour.SRGB (Colour, sRGB24read) 5 | 6 | colorMap = [ (Black, "#000000") 7 | , (Red, "#ff6565") 8 | , (Green, "#93d44f") 9 | , (Yellow, "#eab93d") 10 | , (Blue, "#204a87") 11 | , (Magenta, "#ce5c00") 12 | , (Cyan, "#89b6e2") 13 | , (White, "#cccccc") ] 14 | 15 | colorize :: TerminalColor -> Bool -> Colour 16 | colorize termcol bold = sRGB24read . fromJust . lookup termcol cmap 17 | where cmap = if bold then colorMap else colorMap 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/Hstermplay/Main.hs: -------------------------------------------------------------------------------- 1 | -- |This program will replay the recordings of the `script` utility and 2 | -- output the last screen. 3 | module Main where 4 | import System.Environment (getArgs) 5 | import Control.Monad (foldM) 6 | import System.IO (readFile) 7 | import Terminal.Parser (parseANSIAnnotate) 8 | import Terminal.Types (Terminal) 9 | import Terminal.Terminal (defaultTerm, applyAction) 10 | import Terminal.Debug (printTerminal) 11 | 12 | renderAnnotatedAction (action, bytes) = do 13 | putStrLn $ sb ++ replicate (10 - length sb) ' ' ++ "\t" ++ show action 14 | where sb = show bytes 15 | 16 | -- |Parse a string and apply the resulting TerminalActions to a default 17 | -- terminal. While at it, print each TerminalAction and the resulting 18 | -- terminal state. 19 | playScript :: String -> IO () 20 | playScript s = do 21 | resultTerm <- foldM applyAction' defaultTerm annotatedActions 22 | printTerminal resultTerm 23 | where (Right (annotatedActions, _)) = parseANSIAnnotate s 24 | applyAction' term (a, t) = do 25 | renderAnnotatedAction (a, t) 26 | return (applyAction a term) 27 | 28 | main = getArgs >>= readFile . head >>= playScript 29 | -------------------------------------------------------------------------------- /src/Terminal/Debug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | module Terminal.Debug (printTerminal) where 3 | import Data.Array.Diff ( elems, (//) ) 4 | import System.IO 5 | -- import Data.Set (elems) 6 | import Terminal.Types 7 | 8 | -- | Standard build function. 9 | build :: (forall b. (a -> b -> b) -> b -> b) -> [a] 10 | build g = g (:) [] 11 | 12 | chunk :: Int -> [s] -> [[s]] 13 | chunk i ls = map (take i) (build (splitter ls)) where 14 | splitter [] _ n = n 15 | splitter l c n = l `c` splitter (drop i l) c n 16 | 17 | -- |Debug function to print the current terminal state to the console 18 | printTerminal term = do 19 | print $ (cursorPos term) 20 | putStrLn $ "," ++ (replicate (cols term) '_') ++ "," 21 | mapM_ 22 | (putStrLn . (wrap "|")) 23 | (chunk (cols term) $ map character $ elems (screen term)) 24 | putStrLn $ "`" ++ (replicate (cols term) '"') ++ "´" 25 | hFlush stdout 26 | where wrap d s = d ++ s ++ d 27 | -------------------------------------------------------------------------------- /src/Terminal/Parser.hs: -------------------------------------------------------------------------------- 1 | module Terminal.Parser (parseANSI, parseANSIAnnotate) where 2 | import Control.Monad 3 | import Control.Applicative hiding (many, (<|>)) 4 | import Control.Monad.State 5 | import System.IO 6 | import System.Exit 7 | import Data.Char 8 | import Text.Parsec 9 | import Text.Parsec.String 10 | import Debug.Trace 11 | import Data.List (insert) 12 | import Data.Maybe (maybeToList) 13 | import qualified Text.Parsec.Token as PT 14 | 15 | import Terminal.Types 16 | import Terminal.ParserUtils 17 | 18 | -- TODO: choose another name 19 | simplify :: TerminalAction -> TerminalAction 20 | simplify (ANSIAction [] 'A') = CursorUp 1 21 | simplify (ANSIAction [n] 'A') = CursorUp n 22 | simplify (ANSIAction [] 'B') = CursorDown 1 23 | simplify (ANSIAction [n] 'B') = CursorDown n 24 | simplify (ANSIAction [] 'C') = CursorForward 1 25 | simplify (ANSIAction [n] 'C') = CursorForward n 26 | simplify (ANSIAction [] 'D') = CursorBackward 1 27 | simplify (ANSIAction [n] 'D') = CursorBackward n 28 | simplify (ANSIAction [n] 'G') = CursorAbsoluteColumn n 29 | simplify (ANSIAction [n] 'd') = CursorAbsoluteRow n 30 | simplify (ANSIAction [25] 'h') = ShowCursor True 31 | simplify (ANSIAction [25] 'l') = ShowCursor False 32 | simplify (ANSIAction [] 'H') = SetCursor 1 1 33 | simplify (ANSIAction [] 'f') = SetCursor 1 1 34 | simplify (ANSIAction [y,x] 'H') = SetCursor y x 35 | simplify (ANSIAction [y,x] 'f') = SetCursor y x 36 | 37 | simplify (ANSIAction [start, end] 'r') = SetScrollingRegion start end 38 | simplify (ANSIAction [] 'S') = ScrollUp 1 39 | simplify (ANSIAction [n] 'S') = ScrollUp n 40 | simplify (ANSIAction [] 'T') = ScrollDown 1 41 | simplify (ANSIAction [n] 'T') = ScrollDown n 42 | 43 | simplify (ANSIAction attrModeNumbers 'm') = SetAttributeMode (map toEnum attrModeNumbers) 44 | simplify x = x 45 | 46 | parseString :: String -> [TerminalAction] 47 | parseString str = fst (fromRight (parseANSI str)) 48 | where fromRight :: Either a b -> b 49 | fromRight (Right r) = r 50 | 51 | parseANSI :: String -> Either ParseError ([TerminalAction], String) 52 | parseANSI s = parse (manyWithLeftover pSingle) "" s 53 | 54 | -- |Parse incoming text, and return each TerminalAction annotated with the 55 | -- parsed string. This is usefull for debugging. 56 | parseANSIAnnotate :: String -> Either ParseError ([(TerminalAction, String)], String) 57 | parseANSIAnnotate s = parse (manyWithLeftover $ annotate pSingle) "" s 58 | 59 | pSingle :: Parser TerminalAction 60 | pSingle = (pANSISequence <|> pChar) >>= return . simplify 61 | 62 | pANSISequence :: Parser (TerminalAction) 63 | pANSISequence = try (pStandardANSISeq) 64 | <|> try (pSetTerminalTitle) 65 | <|> try (string "\ESCM" >> return (ScrollUp 1)) 66 | <|> try (string "\ESCD" >> return (ScrollDown 1)) 67 | <|> try (string "\ESC=" >> return KeypadKeysApplicationsMode) 68 | <|> try (string "\ESC>" >> return KeypadKeysNumericMode) 69 | <|> try (string "\ESC(B" >> return Ignored) 70 | <|> try (string "\ESC#8" >> return Ignored) 71 | -- Catch invalid and not implemented sequences 72 | <|> try (string "\ESC" >> notFollowedBy (string "]0;") >> manyTill anyNonEscapeChar (letter <|> try (char '\ESC')) >> return Ignored) 73 | 74 | pStandardANSISeq = do 75 | string "\ESC[" 76 | optionMaybe (char '?') 77 | param <- optionMaybe pNumber 78 | params <- manyUpTo 0 2 (char ';' >> pNumber) 79 | c <- letter 80 | return $ ANSIAction (maybeToList param ++ params) c 81 | 82 | pSetTerminalTitle = do 83 | string "\ESC]0;" 84 | title <- manyTill (satisfy (/= '\007')) (try (char '\007')) 85 | return (SetTerminalTitle title) 86 | 87 | anyNonEscapeChar = satisfy (/= '\ESC') 88 | 89 | pChar :: Parser (TerminalAction) 90 | pChar = (anyNonEscapeChar >>= return . CharInput) 91 | 92 | pNumber = read `fmap` (manyUpTo 1 6 digit) 93 | 94 | main = do 95 | print $ parseANSI "wldjawlkdj1234\a\n\n\ESC[0m\ESC[1;6m\ESC[2K\ESC[A\n12\n" 96 | print $ parseANSI "|M}\210\195\238\ESC[;\171\&2`[ZZZ_`__a\\a]\\aaa`_Z][" 97 | print $ parseANSIAnnotate "\ESC[1;6m\ESC[2K\ESC[A\n12\n" 98 | 99 | -------------------------------------------------------------------------------- /src/Terminal/ParserUtils.hs: -------------------------------------------------------------------------------- 1 | -- General parsec helpers 2 | module Terminal.ParserUtils where 3 | import Text.Parsec 4 | import Text.Parsec.String 5 | import Data.Maybe (catMaybes) 6 | 7 | -- |Apply parser p and return its result together with the string that has been 8 | -- parsed. 9 | annotate p = do 10 | before <- getInput 11 | result <- p 12 | after <- getInput 13 | return (result, take (length before - length after) before) 14 | 15 | -- |Apply parser p as often as possible and return the matches together with the 16 | -- bytes that are not successfully parsed (that are left over) 17 | manyWithLeftover p = do 18 | x <- many p 19 | i <- getInput 20 | return (x, i) 21 | 22 | -- |Apply parser p at least n and up to m times 23 | manyUpTo n m p = do 24 | first <- count n p 25 | rest <- count (m - n) (optionMaybe p) 26 | return (first ++ (catMaybes rest)) 27 | 28 | -------------------------------------------------------------------------------- /src/Terminal/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types #-} 2 | -- Captures how TerminalActions change the Terminal 3 | module Terminal.Terminal (newTerminal, defaultTerm, applyAction, testTerm, scrollTerminalDown, scrollTerminalUp) where 4 | import System.Process 5 | import Data.Array.Diff 6 | import Data.Char 7 | import Control.Monad 8 | import Control.Monad.State hiding (state) 9 | import System.IO 10 | import System.Posix.IO 11 | import System.Posix.Terminal hiding (TerminalState) 12 | import GHC.IO.Handle 13 | import Debug.Trace 14 | import Control.Concurrent 15 | import Control.Applicative hiding (many) 16 | 17 | import Terminal.Parser 18 | import Terminal.Types 19 | 20 | defaultForegroundColor = White 21 | defaultBackgroundColor = Black 22 | 23 | mkChar c term = TerminalChar { 24 | character = c, 25 | foregroundColor = currentForeground term, 26 | backgroundColor = currentBackground term, 27 | isBright = optionBright term, 28 | isBlinking = optionBlinking term, 29 | isUnderlined = optionUnderlined term 30 | } 31 | mkEmptyChar = mkChar ' ' 32 | 33 | testTerm = defaultTerm 34 | defaultTerm = newTerminal (24, 80) 35 | 36 | newTerminal s@(rows, cols) = Terminal { 37 | cursorPos = (1, 1), 38 | rows = rows, 39 | cols = cols, 40 | inBuffer = "", 41 | responseBuffer = "", 42 | scrollingRegion = (1, rows), 43 | screen = array ((1, 1), s) 44 | [((y, x), e) | x <- [1..cols], y <- [1..rows]], 45 | currentForeground = defaultForegroundColor, 46 | currentBackground = defaultBackgroundColor, 47 | optionShowCursor = True, 48 | terminalTitle = "", 49 | optionBright = False, 50 | optionUnderlined = False, 51 | optionBlinking = False 52 | } where e = mkEmptyChar (newTerminal s) -- Hail laziness 53 | 54 | up t@Terminal {cursorPos = (y, x)} = safeCursor $ t { cursorPos = (y - 1, x) } 55 | down t@Terminal {cursorPos = (y, x)} = safeCursor $ t { cursorPos = (y + 1, x) } 56 | left t@Terminal {cursorPos = (y, x)} = safeCursor $ t { cursorPos = (y, x - 1) } 57 | right t@Terminal {cursorPos = (y, x)} = safeCursor $ t { cursorPos = (y, x + 1) } 58 | 59 | -- Wrap line 60 | safeCursor t@Terminal {cursorPos = (y, 81) } = 61 | safeCursor $ t { cursorPos = (y + 1, 1) } 62 | 63 | safeCursor t@Terminal {cursorPos = (25, x), screen = s } = 64 | safeCursor $ scrollTerminalDown $ t { cursorPos = (24, 1) } 65 | 66 | safeCursor term@Terminal {cursorPos = (y, x), cols = c, rows = r } = 67 | term { cursorPos = (min r (max 1 y), min c (max 1 x)) } 68 | 69 | scrollIndexUp :: (Int, Int) -> ScreenIndex -> ScreenIndex 70 | scrollIndexUp (startrow, endrow) (y, x) 71 | | y > startrow && y <= endrow = (y - 1, x) 72 | | y == startrow = (endrow, x) 73 | | otherwise = (y, x) 74 | 75 | scrollIndexDown :: (Int, Int) -> ScreenIndex -> ScreenIndex 76 | scrollIndexDown (startrow, endrow) (y, x) 77 | | y >= startrow && y < endrow = (y + 1, x) 78 | | y == endrow = (startrow, x) 79 | | otherwise = (y, x) 80 | 81 | scrollScreenUp r@(startrow, endrow) screen = 82 | ixmap ((1, 1), (24, 80)) (scrollIndexUp r) screen 83 | 84 | scrollScreenDown r@(startrow, endrow) screen = 85 | ixmap ((1, 1), (24, 80)) (scrollIndexDown r) screen 86 | 87 | scrollTerminalUp :: Terminal -> Terminal 88 | scrollTerminalUp term@Terminal { screen = s, scrollingRegion = r@(startrow, endrow) } = 89 | clearRows [startrow] $ term { 90 | screen = scrollScreenUp (scrollingRegion term) s 91 | } 92 | 93 | scrollTerminalDown :: Terminal -> Terminal 94 | scrollTerminalDown term@Terminal { screen = s, scrollingRegion = r@(startrow, endrow) } = 95 | clearRows [endrow] $ term { 96 | screen = scrollScreenDown (scrollingRegion term) s 97 | } 98 | 99 | clearRows :: [Int] -> Terminal -> Terminal 100 | clearRows rows term@Terminal { screen = s } = 101 | term { 102 | screen = s // [((y_,x_), mkEmptyChar term)|x_<-[1..80],y_<-rows] 103 | } 104 | 105 | clearColumns :: Int -> [Int] -> Terminal -> Terminal 106 | clearColumns row cols term@Terminal { screen = s } = 107 | term { 108 | screen = s // [((row,x_), mkEmptyChar term)|x_<-cols] 109 | } 110 | 111 | -- Attribute mode handling 112 | applyAttributeMode :: Terminal -> AttributeMode -> Terminal 113 | applyAttributeMode term ResetAllAttributes = 114 | term { 115 | currentForeground = defaultForegroundColor, 116 | currentBackground = defaultBackgroundColor, 117 | optionBright = False, 118 | optionUnderlined = False, 119 | optionBlinking = False 120 | } 121 | applyAttributeMode term (Foreground c) = term { currentForeground = c } 122 | applyAttributeMode term (Background c) = term { currentBackground = c } 123 | applyAttributeMode term ResetForeground = term { currentForeground = defaultForegroundColor } 124 | applyAttributeMode term ResetBackground = term { currentBackground = defaultBackgroundColor } 125 | applyAttributeMode term Bright = term { optionBright = True } 126 | applyAttributeMode term Normal = term { optionBright = False } 127 | applyAttributeMode term Underlined = term { optionUnderlined = True } 128 | applyAttributeMode term NotUnderlined = term { optionUnderlined = False } 129 | applyAttributeMode term Blinking = term { optionBlinking = True } 130 | applyAttributeMode term NotBlinking = term { optionBlinking = False } 131 | applyAttributeMode term other = trace ("\nUnimplemented attribute mode: " ++ show other) term 132 | 133 | applyAction :: TerminalAction -> Terminal -> Terminal 134 | applyAction act term@Terminal { screen = s, cursorPos = pos@(y, x) } = 135 | safeCursor t 136 | -- where t = case (trace ("Action" ++ show act) act) of 137 | where t = case act of 138 | Ignored -> term 139 | 140 | -- Bell 141 | CharInput '\a' -> term 142 | 143 | -- Tab 144 | CharInput '\t' -> term { cursorPos = (y, (x `div` 8 + 1) * 8) } 145 | 146 | -- Newline 147 | CharInput '\n' -> term { cursorPos = (y + 1, 1) } 148 | CharInput '\r' -> term { cursorPos = (y, 1) } 149 | CharInput '\b' -> term { screen = s // [(pos, mkEmptyChar term)], cursorPos = (y, x - 1) } 150 | CharInput c -> term { 151 | screen = s // [(pos, mkChar c term)], 152 | cursorPos = (y, x + 1) } 153 | 154 | -- Cursor movements 155 | CursorUp n -> (iterate up term) !! n 156 | CursorDown n -> (iterate down term) !! n 157 | CursorForward n -> (iterate right term) !! n 158 | CursorBackward n -> (iterate left term) !! n 159 | CursorAbsoluteColumn col -> term { cursorPos = (y, col) } 160 | CursorAbsoluteRow row -> term { cursorPos = (row, x) } 161 | SetCursor row col -> term { cursorPos = (row, col) } 162 | 163 | -- Cursor visibility 164 | ShowCursor s -> term { optionShowCursor = s } 165 | 166 | -- Colors, yay! 167 | ANSIAction _ 'm' -> term 168 | 169 | -- Scrolling 170 | SetScrollingRegion start end -> term { scrollingRegion = (start, end) } 171 | ScrollUp n -> (iterate scrollTerminalUp term) !! n 172 | ScrollDown n -> (iterate scrollTerminalDown term) !! n 173 | 174 | -- Erases the screen with the background color and moves the cursor to home. 175 | ANSIAction [2] 'J' -> clearRows [1..24] $ term { cursorPos = (1, 1) } 176 | 177 | -- Erases the screen from the current line up to the top of the screen. 178 | ANSIAction [1] 'J' -> clearRows [1..y] term 179 | 180 | -- Erases the screen from the current line down to the bottom of the screen. 181 | ANSIAction _ 'J' -> clearRows [y..24] term 182 | 183 | -- Erases the entire current line. 184 | ANSIAction [2] 'K' -> clearColumns y [1..80] term 185 | 186 | -- Erases from the current cursor position to the start of the current line. 187 | ANSIAction [1] 'K' -> clearColumns y [1..x] term 188 | 189 | -- Erases from the current cursor position to the end of the current line. 190 | ANSIAction _ 'K' -> clearColumns y [x..80] term 191 | 192 | -- Set the terminal title 193 | SetTerminalTitle t -> term { terminalTitle = t } 194 | 195 | -- Attribute mode / color handling 196 | SetAttributeMode ms -> foldl applyAttributeMode term ms 197 | 198 | _ -> trace ("\nUnimplemented action: " ++ show act) term 199 | 200 | -------------------------------------------------------------------------------- /src/Terminal/Types.hs: -------------------------------------------------------------------------------- 1 | module Terminal.Types where 2 | import Data.Array.Diff 3 | import Data.Char 4 | import Data.Maybe (fromJust, fromMaybe) 5 | import Data.Tuple (swap) 6 | 7 | type ScreenIndex = (Int, Int) 8 | 9 | data TerminalChar = TerminalChar { 10 | character :: Char, 11 | foregroundColor :: TerminalColor, 12 | backgroundColor :: TerminalColor, 13 | isBright :: Bool, 14 | isUnderlined :: Bool, 15 | isBlinking :: Bool 16 | } deriving (Show) 17 | 18 | type TerminalArray = DiffArray ScreenIndex 19 | type TerminalScreen = TerminalArray TerminalChar 20 | type TerminalColorArray = TerminalArray Int 21 | 22 | data Terminal = Terminal { 23 | cursorPos :: ScreenIndex, 24 | screen :: TerminalScreen, 25 | inBuffer :: String, 26 | responseBuffer :: String, 27 | terminalTitle :: String, 28 | scrollingRegion :: (Int, Int), 29 | rows :: Int, 30 | cols :: Int, 31 | 32 | currentForeground :: TerminalColor, 33 | currentBackground :: TerminalColor, 34 | 35 | optionShowCursor :: Bool, 36 | optionBright :: Bool, 37 | optionUnderlined :: Bool, 38 | optionBlinking :: Bool 39 | } 40 | 41 | data TerminalAction = 42 | CharInput Char 43 | 44 | -- Cursor movements 45 | | CursorUp Int 46 | | CursorDown Int 47 | | CursorForward Int 48 | | CursorBackward Int 49 | | SetCursor Int Int 50 | | CursorAbsoluteColumn Int 51 | | CursorAbsoluteRow Int 52 | 53 | -- Scrolling 54 | | SetScrollingRegion Int Int 55 | | ScrollUp Int 56 | | ScrollDown Int 57 | 58 | | ANSIAction [Int] Char 59 | | KeypadKeysApplicationsMode 60 | | KeypadKeysNumericMode 61 | | SetAttributeMode [AttributeMode] 62 | | SetTerminalTitle String 63 | | ShowCursor Bool 64 | | Ignored 65 | deriving (Show, Eq) 66 | 67 | data TerminalColor = 68 | Black 69 | | Red 70 | | Green 71 | | Yellow 72 | | Blue 73 | | Magenta 74 | | Cyan 75 | | White 76 | deriving (Show, Eq) 77 | 78 | instance Enum TerminalColor where 79 | fromEnum = fromJust . flip lookup tableTC 80 | toEnum = fromJust . flip lookup (map swap tableTC) 81 | tableTC = [ (Black, 0) 82 | , (Red, 1) 83 | , (Green, 2) 84 | , (Yellow, 3) 85 | , (Blue, 4) 86 | , (Magenta, 5) 87 | , (Cyan, 6) 88 | , (White, 7) 89 | ] 90 | 91 | data AttributeMode = 92 | InvalidAttributeMode 93 | | ResetAllAttributes 94 | | Bright 95 | | Dim 96 | | Underlined 97 | | Blinking 98 | | Inverse 99 | | Hidden 100 | | Normal 101 | | NotUnderlined 102 | | NotBlinking 103 | | NotInverse 104 | | NotHidden 105 | | Foreground TerminalColor 106 | | Background TerminalColor 107 | | ResetForeground 108 | | ResetBackground 109 | deriving (Show, Eq) 110 | 111 | instance Enum AttributeMode where 112 | fromEnum = fromJust . flip lookup tableAM 113 | toEnum = (fromMaybe InvalidAttributeMode) . flip lookup (map swap tableAM) 114 | tableAM = [ (ResetAllAttributes, 0) 115 | , (Bright, 1) 116 | , (Dim, 2) 117 | , (Underlined, 4) 118 | , (Blinking, 5) 119 | , (Inverse, 7) 120 | , (Hidden, 8) 121 | , (Normal, 22) 122 | , (NotUnderlined, 24) 123 | , (NotBlinking, 25) 124 | , (NotInverse, 27) 125 | , (NotHidden, 28) 126 | ] ++ [(Foreground tcol, 30 + fromEnum tcol) | tcol <- [Black .. White]] 127 | ++ [(Background tcol, 40 + fromEnum tcol) | tcol <- [Black .. White]] 128 | ++ [(ResetForeground, 39), (ResetBackground, 49)] 129 | 130 | -------------------------------------------------------------------------------- /terminal.cabal: -------------------------------------------------------------------------------- 1 | Name: Terminal 2 | Version: 0.0.3 3 | Description: Haskell terminal emulator 4 | License: GPL 5 | License-file: LICENSE 6 | Author: Hannes Gräuler 7 | Maintainer: hgraeule@uos.de 8 | Build-Type: Simple 9 | Cabal-Version: >=1.2 10 | Extra-source-files: README.md 11 | Data-Files: data/fonts/*/*.ttf data/*.sh 12 | 13 | Executable hsterm 14 | Main-is: Main.hs 15 | Hs-Source-Dirs: src/Hsterm, src 16 | Extensions: CPP 17 | Build-Depends: base >= 3 && < 5, containers, mtl, stm, random, array 18 | Build-Depends: time, GLUT, OpenGLRaw, GLURaw, OpenGL, parsec, unix, process 19 | Build-Depends: FTGL >= 1.333, colour, diffarray 20 | GHC-Options: -O 21 | 22 | Executable hstermplay 23 | Main-is: Main.hs 24 | Hs-Source-Dirs: src/Hstermplay, src 25 | Extensions: CPP 26 | Build-Depends: base >= 3 && < 5, containers, mtl, stm, random, array 27 | Build-Depends: time, parsec, unix, process, diffarray 28 | 29 | test-suite TerminalTests 30 | type: exitcode-stdio-1.0 31 | x-uses-tf: true 32 | build-depends: 33 | base >= 4 && < 5, 34 | QuickCheck >= 2.4, 35 | test-framework >= 0.4.1, 36 | test-framework-quickcheck2, 37 | HUnit, 38 | diffarray, 39 | test-framework-hunit 40 | hs-source-dirs: tests/terminal, src 41 | main-is: Main.hs 42 | 43 | test-suite ParserTests 44 | type: exitcode-stdio-1.0 45 | x-uses-tf: true 46 | build-depends: 47 | base >= 4 && < 5, 48 | QuickCheck >= 2.4, 49 | test-framework >= 0.4.1, 50 | test-framework-quickcheck2, 51 | HUnit, 52 | diffarray, 53 | test-framework-hunit 54 | hs-source-dirs: tests/parser, src 55 | main-is: Main.hs 56 | -------------------------------------------------------------------------------- /tests/parser/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Data.Monoid 3 | import System.Random (getStdGen) 4 | import Control.Applicative ((<$>)) 5 | 6 | import Test.Framework 7 | import Test.Framework.Providers.HUnit 8 | import Test.Framework.Providers.QuickCheck2 9 | import Test.HUnit 10 | import Test.QuickCheck hiding ((==>),) 11 | 12 | import Terminal.Parser 13 | import Terminal.Terminal 14 | import Terminal.Types 15 | 16 | -- |This section contains unit tests to validate the parser, that is to ensure 17 | -- that the incoming character stream is correctly translated into 18 | -- `TerminalAction`s. This fact is clearly expressed by the function signature 19 | -- of the assertion function parsesTo which is used in the assertions below. 20 | parsesTo :: String -> [TerminalAction] -> Assertion 21 | parsesTo str is = let Right result = parseANSI str in result @?= (is, "") 22 | 23 | (==>) = parsesTo 24 | 25 | testSetCursor = "A\ESC[H\ESC[2;2H" 26 | ==> [CharInput 'A', SetCursor 1 1, SetCursor 2 2] 27 | 28 | testInvalidSetCursor = "\ESC[H\ESC[2;2;X\ESC[5;1H" 29 | ==> [SetCursor 1 1, Ignored, SetCursor 5 1] 30 | 31 | testMoveCursor = "A\ESC[A\ESCA\ESC[10B" 32 | ==> [CharInput 'A', CursorUp 1, Ignored, CursorDown 10] 33 | 34 | testScrolling = "\ESC[T\ESC[2S\ESC[4T\ESC[S" 35 | ==> [ScrollDown 1, ScrollUp 2, ScrollDown 4, ScrollUp 1] 36 | 37 | testCharInput = "A2$?" 38 | ==> [CharInput 'A', CharInput '2', CharInput '$', CharInput '?'] 39 | 40 | testCharInputIg = "\ESC[;nw\ESC[5652;7974;10;;;xA" 41 | ==> [Ignored, CharInput 'w', Ignored, CharInput 'A'] 42 | 43 | testSetDisplayAttributes1 = "\ESC[0m" 44 | ==> [SetAttributeMode [ResetAllAttributes]] 45 | 46 | testSetDisplayAttributes2 = "\ESC[31;40m\ESC[25m" 47 | ==> [SetAttributeMode [Foreground Red, Background Black], SetAttributeMode [NotBlinking]] 48 | 49 | testSetDisplayAttributes3 = "\ESC[37;4mU\ESC[0m" 50 | ==> [SetAttributeMode [Foreground White, Underlined], 51 | CharInput 'U', 52 | SetAttributeMode [ResetAllAttributes]] 53 | 54 | testSetDisplayAttributes4 = "\ESC[30;5;43m" 55 | ==> [SetAttributeMode [Foreground Black, Blinking, Background Yellow]] 56 | 57 | testSetDisplayAttributes5 = "\ESC[1111m\ESC[50m" 58 | ==> [SetAttributeMode [InvalidAttributeMode], SetAttributeMode [InvalidAttributeMode]] 59 | 60 | testSetTerminalTitle = "\ESC]0;Chickens don't clap!\007b" 61 | ==> [SetTerminalTitle "Chickens don't clap!", CharInput 'b'] 62 | 63 | unitTests = 64 | [ testCase "testSetCursor" testSetCursor 65 | , testCase "testInvalidSetCursor" testInvalidSetCursor 66 | , testCase "testMoveCursor" testMoveCursor 67 | , testCase "testScrolling" testScrolling 68 | , testCase "testCharInput" testCharInput 69 | , testCase "testCharInputIg" testCharInputIg 70 | , testCase "testSetDisplayAttributes1" testSetDisplayAttributes1 71 | , testCase "testSetDisplayAttributes2" testSetDisplayAttributes2 72 | , testCase "testSetDisplayAttributes3" testSetDisplayAttributes3 73 | , testCase "testSetDisplayAttributes4" testSetDisplayAttributes4 74 | , testCase "testSetDisplayAttributes5" testSetDisplayAttributes5 75 | , testCase "testResetColors" 76 | ("\ESC[39;49m" ==> [SetAttributeMode [ResetForeground, ResetBackground]]) 77 | , testCase "testSetTerminalTitle" testSetTerminalTitle 78 | ] 79 | 80 | -- |The second section of this file consists of QuickCheck properties to ensure 81 | -- that the peraser is rebust again arbirtrary input. Therefore a InputStream 82 | -- type is defined which represents the incoming character stream. 83 | newtype InputStream = InputStream String deriving Show 84 | 85 | instance Arbitrary InputStream where 86 | arbitrary = InputStream . concat <$> (listOf1 $ oneof [ 87 | return "\ESC[", 88 | return ";", 89 | listOf1 $ choose ('a', 'z'), 90 | show <$> (choose (0, 100) :: Gen Int), 91 | listOf1 $ choose ('\x00', '\xFF') 92 | ]) 93 | 94 | prop_NotManyCharsLeftOver (InputStream str) = 95 | let Right (x, s) = parseANSI str in 96 | length s < 15 97 | 98 | propertyTests = 99 | [ testProperty "parseNotManyCharsLeftOver" prop_NotManyCharsLeftOver 100 | ] 101 | 102 | -- Finally, execute the tests with the cabal test framework 103 | main :: IO () 104 | main = defaultMainWithOpts (unitTests ++ propertyTests) mempty 105 | 106 | -------------------------------------------------------------------------------- /tests/terminal/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Data.Monoid 3 | import Control.Applicative ((<$>)) 4 | 5 | import Test.Framework 6 | import Test.Framework.Providers.HUnit 7 | import Test.Framework.Providers.QuickCheck2 8 | import Test.HUnit 9 | import Test.QuickCheck 10 | 11 | import Data.Array.IArray ((!)) 12 | 13 | import Terminal.Parser 14 | import Terminal.Terminal 15 | import Terminal.Types 16 | 17 | handleActions [] t = t 18 | handleActions (a : as) t = handleActions as (applyAction a t) 19 | 20 | -- |Apply a list of `TerminalAction`s to the default terminal 21 | applyDef actions = handleActions actions defaultTerm 22 | 23 | -- |Test if currentForeground, currentBackground can be set 24 | testColors :: Assertion 25 | testColors = let term = applyDef [CharInput 'a', 26 | SetAttributeMode [Foreground Green], 27 | CharInput 'b', 28 | SetAttributeMode [Background Yellow, Blinking] 29 | ] in 30 | [currentForeground term, currentBackground term] @?= [Green, Yellow] 31 | 32 | -- |Test if currentForeground, currentBackground can be set 33 | testBackgroundDel = TestCase (do 34 | let term = applyDef [ 35 | SetAttributeMode [Background Yellow], 36 | ANSIAction [2] 'J', 37 | SetAttributeMode [Background White], 38 | CharInput 'a', 39 | SetAttributeMode [Background Green], 40 | ANSIAction [] 'K' 41 | ] 42 | assertEqual "background color in the middle is yellow" 43 | (backgroundColor $ (screen term) ! (10, 10)) (Yellow) 44 | assertEqual "background color in the middle is yellow" 45 | (backgroundColor $ (screen term) ! (10, 1)) (Yellow) 46 | assertEqual "background color is white at (1,1)" 47 | (backgroundColor $ (screen term) ! (1, 1)) (White) 48 | assertEqual "background color is green till the end of line" 49 | (backgroundColor $ (screen term) ! (1, 2)) (Green) 50 | assertEqual "background color is green till the end of line" 51 | (backgroundColor $ (screen term) ! (1, 50)) (Green)) 52 | 53 | -- |Test if colors actually have any influence on the foreground/background 54 | -- arrays 55 | testColors2 = TestCase (do 56 | let term = applyDef [SetAttributeMode [Foreground Green], 57 | SetAttributeMode [Background Magenta], 58 | CharInput 'H', 59 | SetAttributeMode [Background White], 60 | CharInput 'i', 61 | CharInput '\n', 62 | SetAttributeMode [Foreground Yellow, Blinking], 63 | CharInput 'X', 64 | SetAttributeMode [ResetAllAttributes], 65 | CharInput '\n', 66 | CharInput 'Y', 67 | CharInput '\r' 68 | ] 69 | assertEqual "cursor is at the beginning of third row" 70 | (cursorPos term) (3, 1) 71 | assertEqual "foreground color is correct in first char" 72 | (foregroundColor $ (screen term) ! (1, 1)) (Green) 73 | assertEqual "background color is correct in first char" 74 | (backgroundColor $ (screen term) ! (1, 1)) (Magenta) 75 | assertEqual "background color is correct in second char" 76 | (backgroundColor $ (screen term) ! (1, 2)) (White) 77 | assertEqual "foreground color is correct in second row" 78 | (foregroundColor $ (screen term) ! (2, 1)) (Yellow) 79 | assertEqual "background color is default in third row" 80 | (backgroundColor $ (screen term) ! (3, 1)) (Black) 81 | ) 82 | 83 | testSetTerminalTitle = TestCase (do 84 | let s = "There is always money in the banana stand" 85 | term = applyDef [SetTerminalTitle "x", CharInput 'a', SetTerminalTitle s] 86 | assertEqual "title is set" 87 | (terminalTitle term) s) 88 | 89 | testTabCharacter = TestCase (do 90 | let term = applyDef [CharInput '\t', CharInput 'i'] 91 | assertEqual "cursor is at (1, 9)" (cursorPos term) (1, 9)) 92 | 93 | testClearSreen = TestCase (do 94 | let term = applyDef [CharInput 'H', 95 | CharInput 'i', 96 | CharInput '\n', 97 | ANSIAction [2] 'J' 98 | ] 99 | assertEqual "cursor is at the beginning of first row" 100 | (cursorPos term) (1, 1) 101 | assertEqual "first char in first row is empty" 102 | (character $ screen term ! (1, 1)) ' ') 103 | 104 | testColorsDoScroll = TestCase (do 105 | let term = applyDef ([ 106 | SetAttributeMode [Foreground Yellow, Background Green], 107 | CharInput 'X', 108 | SetAttributeMode [ResetAllAttributes] 109 | ] ++ (take 50 $ repeat (CharInput '\n'))) 110 | assertEqual "cursor is at the beginning of last row" 111 | (cursorPos term) (rows term, 1) 112 | assertEqual "background color is default in (1, 1)" 113 | (backgroundColor $ (screen term) ! (1, 1)) Black 114 | assertEqual "foreground color is default in (1, 1)" 115 | (foregroundColor $ (screen term) ! (1, 1)) White 116 | ) 117 | 118 | testColorsBright = TestCase (do 119 | let term = applyDef ([ 120 | SetAttributeMode [Foreground Yellow, Bright], 121 | CharInput '$', CharInput '\n', 122 | SetAttributeMode [Foreground Yellow, Underlined], 123 | CharInput '^', CharInput '\n', 124 | SetAttributeMode [ResetAllAttributes], 125 | CharInput 'o' 126 | ]) 127 | assertEqual "cursor is at the second position in the second row" 128 | (cursorPos term) (3, 2) 129 | assertEqual "character is bright (1, 1)" 130 | (isBright $ (screen term) ! (1, 1)) True 131 | assertEqual "character is bright (2, 1)" 132 | (isBright $ (screen term) ! (2, 1)) True 133 | assertEqual "character is not bright (3, 1)" 134 | (isBright $ (screen term) ! (3, 1)) False 135 | ) 136 | 137 | -- TerminalAction tests 138 | instance Arbitrary TerminalAction where 139 | arbitrary = oneof [ 140 | CharInput <$> choose ('a', 'Z'), 141 | CursorUp <$> choose (1,50), 142 | CursorDown <$> choose (1,50), 143 | CursorForward <$> choose (1,50), 144 | CursorBackward <$> choose (1,50), 145 | SetCursor 34 <$> choose (1, 112) 146 | ] 147 | 148 | -- |Make sure that the cursor always is within bounds 149 | prop_SafeCursor a = 150 | let t = (handleActions a defaultTerm) 151 | (y, x) = cursorPos t in 152 | x >= 1 && y >= 1 && x <= cols t && y <= rows t 153 | 154 | main :: IO () 155 | main = defaultMainWithOpts ( 156 | concat (hUnitTestToTests <$> hUnitTests) 157 | ++ 158 | [ testCase "testColors" testColors 159 | , testProperty "safeCursor" prop_SafeCursor 160 | ]) mempty 161 | where hUnitTests = [testColors2, testClearSreen, testColorsDoScroll, 162 | testSetTerminalTitle, testTabCharacter, 163 | testBackgroundDel, testColorsBright] 164 | -------------------------------------------------------------------------------- /themes/default/background.frag: -------------------------------------------------------------------------------- 1 | #define PI 3.141592653 2 | uniform float cursorx; 3 | uniform float cursory; 4 | uniform float time; 5 | 6 | void main(void) 7 | { 8 | vec2 v = gl_TexCoord[0].xy * PI; 9 | float cols = 80.0; 10 | float rows = 24.0; 11 | float intens = abs(sin(abs(v.y))*sin(abs(v.x))*0.12*sin(time)+0.2); 12 | gl_FragColor = intens * gl_Color; 13 | gl_FragColor[1] -= 1.0 * max(pow(sin((v.x-0.15)*2.0*cols),2.0),-0.15); 14 | gl_FragColor[1] -= 1.0 * max(pow(sin((v.y-0.226)*2.0*rows),2.0),-0.15); 15 | } 16 | -------------------------------------------------------------------------------- /themes/default/background.vert: -------------------------------------------------------------------------------- 1 | void main() 2 | { 3 | gl_TexCoord[0] = gl_MultiTexCoord0; 4 | gl_Position = ftransform(); 5 | gl_FrontColor = gl_Color; 6 | } 7 | -------------------------------------------------------------------------------- /themes/default/cursor.frag: -------------------------------------------------------------------------------- 1 | #define PI 3.141592653 2 | uniform float cursorx; 3 | uniform float cursory; 4 | uniform float time; 5 | 6 | void main(void) 7 | { 8 | vec2 v = gl_TexCoord[0].xy * PI; 9 | float cols = 80.0; 10 | float rows = 24.0; 11 | gl_FragColor[1] = 1.0; 12 | gl_FragColor[2] = 0.25*min(1.0,1.0/abs(1.5*( ((cols-cursorx+0.5)-gl_TexCoord[0].x*cols) ))) 13 | +0.25*min(1.0,1.0/abs(3.0*( ((rows-cursory+0.5)-gl_TexCoord[0].y*rows) ))); 14 | float cursor = (sin(time*10.0)/2.0+0.5)*10.0*(min(1.0,max(0.0,-0.4+0.25*min(1.0,1.0/abs(2.7*( ((cols-cursorx+0.5)-gl_TexCoord[0].x*cols) ))) 15 | +0.25*min(1.0,1.0/abs(3.0*( ((rows-cursory+0.5)-gl_TexCoord[0].y*rows) )))))); 16 | 17 | gl_FragColor[3] = gl_FragColor[2]*0.5 + cursor; 18 | } 19 | -------------------------------------------------------------------------------- /themes/default/cursor.vert: -------------------------------------------------------------------------------- 1 | void main() 2 | { 3 | gl_TexCoord[0] = gl_MultiTexCoord0; 4 | gl_Position = ftransform(); 5 | gl_FrontColor = gl_Color; 6 | } 7 | --------------------------------------------------------------------------------