WIP - Windows command prompt support

.dir-locals.el

@@ -0,0 +1,6 @@
+((haskell-mode . ((haskell-indentation-layout-offset . 4)
+                  (haskell-indentation-starter-offset . 4)
+                  (haskell-indentation-left-offset . 4)
+                  (haskell-indentation-ifte-offset . 4)
+                  (haskell-indentation-where-pre-offset . 4)
+                  (haskell-indentation-where-post-offset . 4))))

.gitignore

@@ -9,3 +9,7 @@ test/benchmark
 .cabal-sandbox
 cabal.sandbox.config
 test/cabal.sandbox.config
+.stack-work
+#
+.#
+*#

.gitmodules

@@ -0,0 +1,7 @@
+[submodule "dependencies/win32"]
+	path = dependencies/win32
+	url = git@github.com:coreyoconnor/win32.git
+[submodule "dependencies/ansi-terminal"]
+	path = dependencies/ansi-terminal
+	url = git@github.com:coreyoconnor/ansi-terminal.git
+	branch = master

.projectile

@@ -0,0 +1,16 @@
+-*.o
+-*.swp
+-*.hi
+-*.prof
+-/Setup
+-/Setup.hi
+-/Setup.o
+-/dist
+-/test/benchmark
+-*.hpc
+-.cabal-sandbox
+-/cabal.sandbox.config
+-/test/cabal.sandbox.config
+-.stack-work
+-#*
+-*#

foreign/posix/gwinsz.c

@@ -0,0 +1,9 @@
+#include <sys/ioctl.h>
+
+unsigned long vty_c_get_window_size(int fd) {
+    struct winsize w;
+    if (ioctl (fd, TIOCGWINSZ, &w) >= 0)
+        return (w.ws_row << 16) + w.ws_col;
+    else
+        return 0x190050;
+}

src/Data/Terminfo/Eval.hs

@@ -18,7 +18,6 @@ import Blaze.ByteString.Builder.Word
 import Blaze.ByteString.Builder
 import Data.Terminfo.Parse
 
-import Control.Monad.Identity
 import Control.Monad.State.Strict
 import Control.Monad.Writer
 
@@ -32,13 +31,14 @@ import Data.Word
 #endif
 
 -- | capability evaluator state
+-- TODO: strict list? Necessary?
 data EvalState = EvalState
-    { evalStack :: ![CapParam]
+    { evalStack      :: ![CapParam]
     , evalExpression :: !CapExpression
-    , evalParams :: ![CapParam]
+    , evalParams     :: ![CapParam]
     }
 
-type Eval a = StateT EvalState (Writer Write) a
+type Eval a = StateT EvalState (Writer Builder) a
 
 pop :: Eval CapParam
 pop = do
@@ -65,7 +65,9 @@ applyParamOps cap params = foldl applyParamOp params (paramOps cap)
 applyParamOp :: [CapParam] -> ParamOp -> [CapParam]
 applyParamOp params IncFirstTwo = map (+ 1) params
 
-writeCapExpr :: CapExpression -> [CapParam] -> Write
+-- | Evaluate the terminfo capability expression with the given paramenters
+-- to a `Builder`.
+writeCapExpr :: CapExpression -> [CapParam] -> Builder
 writeCapExpr cap params =
     let params' = applyParamOps cap params
         s0 = EvalState [] cap params'
@@ -78,20 +80,22 @@ writeCapOp :: CapOp -> Eval ()
 writeCapOp (Bytes !offset !count) = do
     !cap <- get >>= return . evalExpression
     let bytes = Vector.take count $ Vector.drop offset (capBytes cap)
-    Vector.forM_ bytes $ tell.writeWord8
+    tell $ foldMap (fromWrite . writeWord8) (Vector.toList bytes)
 writeCapOp DecOut = do
     p <- pop
-    forM_ (show p) $ tell.writeWord8.toEnum.fromEnum
+    tell $ foldMap (fromWrite.writeWord8.toEnum.fromEnum) (show p)
 writeCapOp CharOut = do
-    pop >>= tell.writeWord8.toEnum.fromEnum 
+    pop >>= tell.fromWrite.writeWord8.toEnum.fromEnum
 writeCapOp (PushParam pn) = do
     readParam pn >>= push
 writeCapOp (PushValue v) = do
     push v
+-- This violates the precondition for using a Write:
+-- "it is important to ensure that the bound on the number of bytes written is data-independent"
 writeCapOp (Conditional expr parts) = do
     writeCapOps expr
     writeContitionalParts parts
-    where 
+    where
         writeContitionalParts [] = return ()
         writeContitionalParts ((trueOps, falseOps) : falseParts) = do
             -- (man 5 terminfo)
@@ -137,4 +141,3 @@ writeCapOp CompareGt = do
     v1 <- pop
     v0 <- pop
     push $ if v0 > v1 then 1 else 0
-

src/Graphics/Vty.hs

@@ -10,7 +10,7 @@
 --      - The constructors in "Graphics.Vty.Image.Internal" should not be used.
 --
 --  - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
--- 
+--
 -- See the vty-examples package for a number of examples.
 --
 -- @
@@ -28,7 +28,7 @@
 --      'shutdown' vty
 --      'print' (\"Last event was: \" '++' 'show' e)
 -- @
--- 
+--
 -- Good sources of documentation for terminal programming are:
 --
 --  - <https://github.com/b4winckler/vim/blob/master/src/term.c>
@@ -49,7 +49,7 @@ module Graphics.Vty ( Vty(..)
                     , module Graphics.Vty.Output
                     , module Graphics.Vty.Picture
                     , DisplayRegion
-                    ) 
+                    )
     where
 
 import Graphics.Vty.Prelude
@@ -82,7 +82,7 @@ import Data.Monoid
 -- when another update action is already then it's safe to call this on multiple threads.
 --
 -- \todo Remove explicit `shutdown` requirement.
-data Vty = Vty 
+data Vty = Vty
     { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context
       -- implicitly managed by Vty. The managed display context is reset on resize.
       update :: Picture -> IO ()
@@ -99,7 +99,7 @@ data Vty = Vty
     , refresh :: IO ()
       -- | Clean up after vty.
       -- The above methods will throw an exception if executed after this is executed.
-    , shutdown :: IO () 
+    , shutdown :: IO ()
     }
 
 -- | Set up the state object for using vty.  At most one state object should be
@@ -145,28 +145,28 @@ intMkVty input out = do
             mlastUpdate <- readIORef lastUpdateRef
             updateData <- case mlastUpdate of
                 Nothing -> do
-                    dc <- displayContext out b
-                    outputPicture dc inPic'
+                    let dc = DisplayContext out b
+                    outputPictureToContext dc inPic'
                     return (b, dc)
                 Just (lastBounds, lastContext) -> do
                     if b /= lastBounds
                         then do
-                            dc <- displayContext out b
-                            outputPicture dc inPic'
+                            let dc = DisplayContext out b
+                            outputPictureToContext dc inPic'
                             return (b, dc)
                         else do
-                            outputPicture lastContext inPic'
+                            outputPictureToContext lastContext inPic'
                             return (b, lastContext)
             writeIORef lastUpdateRef $ Just updateData
             writeIORef lastPicRef $ Just inPic'
 
-    let innerRefresh 
+    let innerRefresh
             =   writeIORef lastUpdateRef Nothing
-            >>  readIORef lastPicRef 
-            >>= maybe ( return () ) ( \pic -> innerUpdate pic ) 
+            >>  readIORef lastPicRef
+            >>= maybe ( return () ) ( \pic -> innerUpdate pic )
 
     let gkey = do k <- atomically $ readTChan $ _eventChannel input
-                  case k of 
+                  case k of
                     (EvResize _ _)  -> innerRefresh
                                        >> displayBounds out
                                        >>= return . (\(w,h)-> EvResize w h)
@@ -179,4 +179,3 @@ intMkVty input out = do
                  , refresh = innerRefresh
                  , shutdown = shutdownIo
                  }
-

src/Graphics/Vty/Attributes.hs

@@ -93,7 +93,7 @@ data Attr = Attr
 
 instance Monoid Attr where
     mempty = Attr mempty mempty mempty
-    mappend attr0 attr1 = 
+    mappend attr0 attr1 =
         Attr ( attrStyle attr0     `mappend` attrStyle attr1 )
              ( attrForeColor attr0 `mappend` attrForeColor attr1 )
              ( attrBackColor attr0 `mappend` attrBackColor attr1 )
@@ -102,7 +102,7 @@ instance Monoid Attr where
 -- the previously applied display attribute. The display attributes can still depend on the
 -- terminal's default colors (unfortunately).
 data FixedAttr = FixedAttr
-    { fixedStyle :: !Style
+    { fixedStyle     :: !Style
     , fixedForeColor :: !(Maybe Color)
     , fixedBackColor :: !(Maybe Color)
     } deriving ( Eq, Show )
@@ -141,7 +141,7 @@ magenta= ISOColor 5
 cyan   = ISOColor 6
 white  = ISOColor 7
 
--- | Bright/Vivid variants of the standard 8-color ANSI 
+-- | Bright/Vivid variants of the standard 8-color ANSI
 brightBlack, brightRed, brightGreen, brightYellow :: Color
 brightBlue, brightMagenta, brightCyan, brightWhite :: Color
 brightBlack  = ISOColor 8
@@ -176,7 +176,7 @@ type Style = Word8
 standout, underline, reverseVideo, blink, dim, bold :: Style
 standout        = 0x01
 underline       = 0x02
-reverseVideo   = 0x04
+reverseVideo    = 0x04
 blink           = 0x08
 dim             = 0x10
 bold            = 0x20
@@ -185,7 +185,7 @@ defaultStyleMask :: Style
 defaultStyleMask = 0x00
 
 styleMask :: Attr -> Word8
-styleMask attr 
+styleMask attr
     = case attrStyle attr of
         Default  -> 0
         KeepCurrent -> 0
@@ -224,4 +224,3 @@ instance Default Attr where
 -- set to brightMagenta.
 currentAttr :: Attr
 currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
-