summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDmitryIvanov <>2016-09-29 16:19:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-09-29 16:19:00 (GMT)
commit0295058127b7f2b4fede66590db12de4fe646691 (patch)
tree2729e15d82da9cb1406c352f813eb5b73155454b
version 0.130.13
-rw-r--r--Setup.hs4
-rw-r--r--src/Yi/Config/Default/HaskellMode.hs13
-rw-r--r--src/Yi/Lexer/Haskell.x265
-rw-r--r--src/Yi/Lexer/LiterateHaskell.x224
-rw-r--r--src/Yi/Mode/GHCi.hs85
-rw-r--r--src/Yi/Mode/Haskell.hs470
-rw-r--r--src/Yi/Mode/Haskell/Dollarify.hs186
-rw-r--r--src/Yi/Syntax/Haskell.hs745
-rw-r--r--src/Yi/Syntax/Paren.hs172
-rw-r--r--src/Yi/Syntax/Strokes/Haskell.hs157
-rw-r--r--test/Spec.hs1
-rw-r--r--test/Yi/Lexer/HaskellSpec.hs64
-rw-r--r--test/Yi/Lexer/Helpers.hs2
-rw-r--r--test/Yi/Lexer/Helpers/TH.hs30
-rw-r--r--yi-mode-haskell.cabal87
15 files changed, 2505 insertions, 0 deletions
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..2b70bbb
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,4 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main :: IO ()
+main = defaultMain
diff --git a/src/Yi/Config/Default/HaskellMode.hs b/src/Yi/Config/Default/HaskellMode.hs
new file mode 100644
index 0000000..3820bdd
--- /dev/null
+++ b/src/Yi/Config/Default/HaskellMode.hs
@@ -0,0 +1,13 @@
+module Yi.Config.Default.HaskellMode (configureHaskellMode) where
+
+import Lens.Micro.Platform ((%=))
+import Yi.Config.Simple (ConfigM, addMode)
+import Yi.Config.Lens (modeTableA)
+import Yi.Mode.Haskell
+import Yi.Types (AnyMode (..))
+
+configureHaskellMode :: ConfigM ()
+configureHaskellMode = do
+ addMode literateMode
+ addMode preciseMode
+ addMode cleverMode
diff --git a/src/Yi/Lexer/Haskell.x b/src/Yi/Lexer/Haskell.x
new file mode 100644
index 0000000..4b7d7e4
--- /dev/null
+++ b/src/Yi/Lexer/Haskell.x
@@ -0,0 +1,265 @@
+-- -*- haskell -*-
+--
+-- Lexical syntax for illiterate Haskell 98.
+--
+-- (c) Simon Marlow 2003, with the caveat that much of this is
+-- translated directly from the syntax in the Haskell 98 report.
+--
+
+{
+{-# OPTIONS -w #-}
+module Yi.Lexer.Haskell ( initState, alexScanToken, tokenToStyle,
+ tokenToText,
+ TT, isErrorTok, isSpecial,
+ startsLayout, isComment, Token(..), HlState, CommentType(..), ReservedType(..), OpType(..) ) where
+import Yi.Lexer.Alex hiding (tokenToStyle)
+import Yi.Style
+}
+
+$whitechar = [\ \t\n\r\f\v]
+$special = [\(\)\,\;\[\]\`\{\}]
+
+$ascdigit = 0-9
+$unidigit = [] -- GHC 8.0.1 Doesn't support unicode decimal digits
+$digit = [$ascdigit $unidigit]
+
+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
+$unisymbol = [\x9\xb\x1f\x24\x2b\x3c-\x3e\x5e\x60\x7c\x7e\xa2-\xa6\xa8\xa9\xac\xae-\xb1\xb4\xb8\xd7\xf7\x2c2-\x2c5\x2d2-\x2df\x2e5-\x2eb\x2ed\x2ef-\x2ff\x375\x384\x385\x3f6\x482\x58d-\x58f\x606-\x608\x60b\x60e\x60f\x6de\x6e9\x6fd\x6fe\x7f6\x9f2\x9f3\x9fa\x9fb\xaf1\xb70\xbf3-\xbfa\xc7f\xd4f\xd79\xe3f\xf01-\xf03\xf13\xf15-\xf17\xf1a-\xf1f\xf34\xf36\xf38\xfbe-\xfc5\xfc7-\xfcc\xfce\xfcf\xfd5-\xfd8\x109e\x109f\x1390-\x1399\x17db\x1940\x19de-\x19ff\x1b61-\x1b6a\x1b74-\x1b7c\x1fbd\x1fbf-\x1fc1\x1fcd-\x1fcf\x1fdd-\x1fdf\x1fed-\x1fef\x1ffd\x1ffe\x2044\x2052\x207a-\x207c\x208a-\x208c\x20a0-\x20be\x2100\x2101\x2103-\x2106\x2108\x2109\x2114\x2116-\x2118\x211e-\x2123\x2125\x2127\x2129\x212e\x213a\x213b\x2140-\x2144\x214a-\x214d\x214f\x218a\x218b\x2190-\x2307\x230c-\x2328\x232b-\x23fe\x2400-\x2426\x2440-\x244a\x249c-\x24e9\x2500-\x2767\x2794-\x27c4\x27c7-\x27e5\x27f0-\x2982\x2999-\x29d7\x29dc-\x29fb\x29fe-\x2b73\x2b76-\x2b95\x2b98-\x2bb9\x2bbd-\x2bc8\x2bca-\x2bd1\x2bec-\x2bef\x2ce5-\x2cea\x2e80-\x2e99\x2e9b-\x2ef3\x2f00-\x2fd5\x2ff0-\x2ffb\x3004\x3012\x3013\x3020\x3036\x3037\x303e\x303f\x309b\x309c\x3190\x3191\x3196-\x319f\x31c0-\x31e3\x3200-\x321e\x322a-\x3247\x3250\x3260-\x327f\x328a-\x32b0\x32c0-\x32fe\x3300-\x33ff\x4dc0-\x4dff\xa490-\xa4c6\xa700-\xa716\xa720\xa721\xa789\xa78a\xa828-\xa82b\xa836-\xa839\xaa77-\xaa79\xab5b\xfb29\xfbb2-\xfbc1\xfdfc\xfdfd\xfe62\xfe64-\xfe66\xfe69\xff04\xff0b\xff1c-\xff1e\xff3e\xff40\xff5c\xff5e\xffe0-\xffe6\xffe8-\xffee\xfffc\xfffd\x10137-\x1013f\x10179-\x10189\x1018c-\x1018e\x10190-\x1019b\x101a0\x101d0-\x101fc\x10877\x10878\x10ac8\x1173f\x16b3c-\x16b3f\x16b45\x1bc9c\x1d000-\x1d0f5\x1d100-\x1d126\x1d129-\x1d164\x1d16a-\x1d16c\x1d183\x1d184\x1d18c-\x1d1a9\x1d1ae-\x1d1e8\x1d200-\x1d241\x1d245\x1d300-\x1d356\x1d6c1\x1d6db\x1d6fb\x1d715\x1d735\x1d74f\x1d76f\x1d789\x1d7a9\x1d7c3\x1d800-\x1d9ff\x1da37-\x1da3a\x1da6d-\x1da74\x1da76-\x1da83\x1da85\x1da86\x1eef0\x1eef1\x1f000-\x1f02b\x1f030-\x1f093\x1f0a0-\x1f0ae\x1f0b1-\x1f0bf\x1f0c1-\x1f0cf\x1f0d1-\x1f0f5\x1f110-\x1f12e\x1f130-\x1f16b\x1f170-\x1f1ac\x1f1e6-\x1f202\x1f210-\x1f23b\x1f240-\x1f248\x1f250\x1f251\x1f300-\x1f6d2\x1f6e0-\x1f6ec\x1f6f0-\x1f6f6\x1f700-\x1f773\x1f780-\x1f7d4\x1f800-\x1f80b\x1f810-\x1f847\x1f850-\x1f859\x1f860-\x1f887\x1f890-\x1f8ad\x1f910-\x1f91e\x1f920-\x1f927\x1f930\x1f933-\x1f93e\x1f940-\x1f94b\x1f950-\x1f95e\x1f980-\x1f991\x1f9c0]
+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
+
+$large = [\x41-\x5a\xc0-\xd6\xd8-\xde\x100\x102\x104\x106\x108\x10a\x10c\x10e\x110\x112\x114\x116\x118\x11a\x11c\x11e\x120\x122\x124\x126\x128\x12a\x12c\x12e\x130\x132\x134\x136\x139\x13b\x13d\x13f\x141\x143\x145\x147\x14a\x14c\x14e\x150\x152\x154\x156\x158\x15a\x15c\x15e\x160\x162\x164\x166\x168\x16a\x16c\x16e\x170\x172\x174\x176\x178\x179\x17b\x17d\x181\x182\x184\x186\x187\x189-\x18b\x18e-\x191\x193\x194\x196-\x198\x19c\x19d\x19f\x1a0\x1a2\x1a4\x1a6\x1a7\x1a9\x1ac\x1ae\x1af\x1b1-\x1b3\x1b5\x1b7\x1b8\x1bc\x1c4\x1c7\x1ca\x1cd\x1cf\x1d1\x1d3\x1d5\x1d7\x1d9\x1db\x1de\x1e0\x1e2\x1e4\x1e6\x1e8\x1ea\x1ec\x1ee\x1f1\x1f4\x1f6-\x1f8\x1fa\x1fc\x1fe\x200\x202\x204\x206\x208\x20a\x20c\x20e\x210\x212\x214\x216\x218\x21a\x21c\x21e\x220\x222\x224\x226\x228\x22a\x22c\x22e\x230\x232\x23a\x23b\x23d\x23e\x241\x243-\x246\x248\x24a\x24c\x24e\x370\x372\x376\x37f\x386\x388-\x38a\x38c\x38e\x38f\x391-\x3a1\x3a3-\x3ab\x3cf\x3d2-\x3d4\x3d8\x3da\x3dc\x3de\x3e0\x3e2\x3e4\x3e6\x3e8\x3ea\x3ec\x3ee\x3f4\x3f7\x3f9\x3fa\x3fd-\x42f\x460\x462\x464\x466\x468\x46a\x46c\x46e\x470\x472\x474\x476\x478\x47a\x47c\x47e\x480\x48a\x48c\x48e\x490\x492\x494\x496\x498\x49a\x49c\x49e\x4a0\x4a2\x4a4\x4a6\x4a8\x4aa\x4ac\x4ae\x4b0\x4b2\x4b4\x4b6\x4b8\x4ba\x4bc\x4be\x4c0\x4c1\x4c3\x4c5\x4c7\x4c9\x4cb\x4cd\x4d0\x4d2\x4d4\x4d6\x4d8\x4da\x4dc\x4de\x4e0\x4e2\x4e4\x4e6\x4e8\x4ea\x4ec\x4ee\x4f0\x4f2\x4f4\x4f6\x4f8\x4fa\x4fc\x4fe\x500\x502\x504\x506\x508\x50a\x50c\x50e\x510\x512\x514\x516\x518\x51a\x51c\x51e\x520\x522\x524\x526\x528\x52a\x52c\x52e\x531-\x556\x10a0-\x10c5\x10c7\x10cd\x13a0-\x13f5\x1e00\x1e02\x1e04\x1e06\x1e08\x1e0a\x1e0c\x1e0e\x1e10\x1e12\x1e14\x1e16\x1e18\x1e1a\x1e1c\x1e1e\x1e20\x1e22\x1e24\x1e26\x1e28\x1e2a\x1e2c\x1e2e\x1e30\x1e32\x1e34\x1e36\x1e38\x1e3a\x1e3c\x1e3e\x1e40\x1e42\x1e44\x1e46\x1e48\x1e4a\x1e4c\x1e4e\x1e50\x1e52\x1e54\x1e56\x1e58\x1e5a\x1e5c\x1e5e\x1e60\x1e62\x1e64\x1e66\x1e68\x1e6a\x1e6c\x1e6e\x1e70\x1e72\x1e74\x1e76\x1e78\x1e7a\x1e7c\x1e7e\x1e80\x1e82\x1e84\x1e86\x1e88\x1e8a\x1e8c\x1e8e\x1e90\x1e92\x1e94\x1e9e\x1ea0\x1ea2\x1ea4\x1ea6\x1ea8\x1eaa\x1eac\x1eae\x1eb0\x1eb2\x1eb4\x1eb6\x1eb8\x1eba\x1ebc\x1ebe\x1ec0\x1ec2\x1ec4\x1ec6\x1ec8\x1eca\x1ecc\x1ece\x1ed0\x1ed2\x1ed4\x1ed6\x1ed8\x1eda\x1edc\x1ede\x1ee0\x1ee2\x1ee4\x1ee6\x1ee8\x1eea\x1eec\x1eee\x1ef0\x1ef2\x1ef4\x1ef6\x1ef8\x1efa\x1efc\x1efe\x1f08-\x1f0f\x1f18-\x1f1d\x1f28-\x1f2f\x1f38-\x1f3f\x1f48-\x1f4d\x1f59\x1f5b\x1f5d\x1f5f\x1f68-\x1f6f\x1fb8-\x1fbb\x1fc8-\x1fcb\x1fd8-\x1fdb\x1fe8-\x1fec\x1ff8-\x1ffb\x2102\x2107\x210b-\x210d\x2110-\x2112\x2115\x2119-\x211d\x2124\x2126\x2128\x212a-\x212d\x2130-\x2133\x213e\x213f\x2145\x2183\x2c00-\x2c2e\x2c60\x2c62-\x2c64\x2c67\x2c69\x2c6b\x2c6d-\x2c70\x2c72\x2c75\x2c7e-\x2c80\x2c82\x2c84\x2c86\x2c88\x2c8a\x2c8c\x2c8e\x2c90\x2c92\x2c94\x2c96\x2c98\x2c9a\x2c9c\x2c9e\x2ca0\x2ca2\x2ca4\x2ca6\x2ca8\x2caa\x2cac\x2cae\x2cb0\x2cb2\x2cb4\x2cb6\x2cb8\x2cba\x2cbc\x2cbe\x2cc0\x2cc2\x2cc4\x2cc6\x2cc8\x2cca\x2ccc\x2cce\x2cd0\x2cd2\x2cd4\x2cd6\x2cd8\x2cda\x2cdc\x2cde\x2ce0\x2ce2\x2ceb\x2ced\x2cf2\xa640\xa642\xa644\xa646\xa648\xa64a\xa64c\xa64e\xa650\xa652\xa654\xa656\xa658\xa65a\xa65c\xa65e\xa660\xa662\xa664\xa666\xa668\xa66a\xa66c\xa680\xa682\xa684\xa686\xa688\xa68a\xa68c\xa68e\xa690\xa692\xa694\xa696\xa698\xa69a\xa722\xa724\xa726\xa728\xa72a\xa72c\xa72e\xa732\xa734\xa736\xa738\xa73a\xa73c\xa73e\xa740\xa742\xa744\xa746\xa748\xa74a\xa74c\xa74e\xa750\xa752\xa754\xa756\xa758\xa75a\xa75c\xa75e\xa760\xa762\xa764\xa766\xa768\xa76a\xa76c\xa76e\xa779\xa77b\xa77d\xa77e\xa780\xa782\xa784\xa786\xa78b\xa78d\xa790\xa792\xa796\xa798\xa79a\xa79c\xa79e\xa7a0\xa7a2\xa7a4\xa7a6\xa7a8\xa7aa-\xa7ae\xa7b0-\xa7b4\xa7b6\xff21-\xff3a\x10400-\x10427\x104b0-\x104d3\x10c80-\x10cb2\x118a0-\x118bf\x1d400-\x1d419\x1d434-\x1d44d\x1d468-\x1d481\x1d49c\x1d49e\x1d49f\x1d4a2\x1d4a5\x1d4a6\x1d4a9-\x1d4ac\x1d4ae-\x1d4b5\x1d4d0-\x1d4e9\x1d504\x1d505\x1d507-\x1d50a\x1d50d-\x1d514\x1d516-\x1d51c\x1d538\x1d539\x1d53b-\x1d53e\x1d540-\x1d544\x1d546\x1d54a-\x1d550\x1d56c-\x1d585\x1d5a0-\x1d5b9\x1d5d4-\x1d5ed\x1d608-\x1d621\x1d63c-\x1d655\x1d670-\x1d689\x1d6a8-\x1d6c0\x1d6e2-\x1d6fa\x1d71c-\x1d734\x1d756-\x1d76e\x1d790-\x1d7a8\x1d7ca\x1e900-\x1e921\x1c5\x1c8\x1cb\x1f2\x1f88-\x1f8f\x1f98-\x1f9f\x1fa8-\x1faf\x1fbc\x1fcc\x1ffc]
+$small = [\x61-\x7a\xb5\xdf-\xf6\xf8-\xff\x101\x103\x105\x107\x109\x10b\x10d\x10f\x111\x113\x115\x117\x119\x11b\x11d\x11f\x121\x123\x125\x127\x129\x12b\x12d\x12f\x131\x133\x135\x137\x138\x13a\x13c\x13e\x140\x142\x144\x146\x148\x149\x14b\x14d\x14f\x151\x153\x155\x157\x159\x15b\x15d\x15f\x161\x163\x165\x167\x169\x16b\x16d\x16f\x171\x173\x175\x177\x17a\x17c\x17e-\x180\x183\x185\x188\x18c\x18d\x192\x195\x199-\x19b\x19e\x1a1\x1a3\x1a5\x1a8\x1aa\x1ab\x1ad\x1b0\x1b4\x1b6\x1b9\x1ba\x1bd-\x1bf\x1c6\x1c9\x1cc\x1ce\x1d0\x1d2\x1d4\x1d6\x1d8\x1da\x1dc\x1dd\x1df\x1e1\x1e3\x1e5\x1e7\x1e9\x1eb\x1ed\x1ef\x1f0\x1f3\x1f5\x1f9\x1fb\x1fd\x1ff\x201\x203\x205\x207\x209\x20b\x20d\x20f\x211\x213\x215\x217\x219\x21b\x21d\x21f\x221\x223\x225\x227\x229\x22b\x22d\x22f\x231\x233-\x239\x23c\x23f\x240\x242\x247\x249\x24b\x24d\x24f-\x293\x295-\x2af\x371\x373\x377\x37b-\x37d\x390\x3ac-\x3ce\x3d0\x3d1\x3d5-\x3d7\x3d9\x3db\x3dd\x3df\x3e1\x3e3\x3e5\x3e7\x3e9\x3eb\x3ed\x3ef-\x3f3\x3f5\x3f8\x3fb\x3fc\x430-\x45f\x461\x463\x465\x467\x469\x46b\x46d\x46f\x471\x473\x475\x477\x479\x47b\x47d\x47f\x481\x48b\x48d\x48f\x491\x493\x495\x497\x499\x49b\x49d\x49f\x4a1\x4a3\x4a5\x4a7\x4a9\x4ab\x4ad\x4af\x4b1\x4b3\x4b5\x4b7\x4b9\x4bb\x4bd\x4bf\x4c2\x4c4\x4c6\x4c8\x4ca\x4cc\x4ce\x4cf\x4d1\x4d3\x4d5\x4d7\x4d9\x4db\x4dd\x4df\x4e1\x4e3\x4e5\x4e7\x4e9\x4eb\x4ed\x4ef\x4f1\x4f3\x4f5\x4f7\x4f9\x4fb\x4fd\x4ff\x501\x503\x505\x507\x509\x50b\x50d\x50f\x511\x513\x515\x517\x519\x51b\x51d\x51f\x521\x523\x525\x527\x529\x52b\x52d\x52f\x561-\x587\x13f8-\x13fd\x1c80-\x1c88\x1d00-\x1d2b\x1d6b-\x1d77\x1d79-\x1d9a\x1e01\x1e03\x1e05\x1e07\x1e09\x1e0b\x1e0d\x1e0f\x1e11\x1e13\x1e15\x1e17\x1e19\x1e1b\x1e1d\x1e1f\x1e21\x1e23\x1e25\x1e27\x1e29\x1e2b\x1e2d\x1e2f\x1e31\x1e33\x1e35\x1e37\x1e39\x1e3b\x1e3d\x1e3f\x1e41\x1e43\x1e45\x1e47\x1e49\x1e4b\x1e4d\x1e4f\x1e51\x1e53\x1e55\x1e57\x1e59\x1e5b\x1e5d\x1e5f\x1e61\x1e63\x1e65\x1e67\x1e69\x1e6b\x1e6d\x1e6f\x1e71\x1e73\x1e75\x1e77\x1e79\x1e7b\x1e7d\x1e7f\x1e81\x1e83\x1e85\x1e87\x1e89\x1e8b\x1e8d\x1e8f\x1e91\x1e93\x1e95-\x1e9d\x1e9f\x1ea1\x1ea3\x1ea5\x1ea7\x1ea9\x1eab\x1ead\x1eaf\x1eb1\x1eb3\x1eb5\x1eb7\x1eb9\x1ebb\x1ebd\x1ebf\x1ec1\x1ec3\x1ec5\x1ec7\x1ec9\x1ecb\x1ecd\x1ecf\x1ed1\x1ed3\x1ed5\x1ed7\x1ed9\x1edb\x1edd\x1edf\x1ee1\x1ee3\x1ee5\x1ee7\x1ee9\x1eeb\x1eed\x1eef\x1ef1\x1ef3\x1ef5\x1ef7\x1ef9\x1efb\x1efd\x1eff-\x1f07\x1f10-\x1f15\x1f20-\x1f27\x1f30-\x1f37\x1f40-\x1f45\x1f50-\x1f57\x1f60-\x1f67\x1f70-\x1f7d\x1f80-\x1f87\x1f90-\x1f97\x1fa0-\x1fa7\x1fb0-\x1fb4\x1fb6\x1fb7\x1fbe\x1fc2-\x1fc4\x1fc6\x1fc7\x1fd0-\x1fd3\x1fd6\x1fd7\x1fe0-\x1fe7\x1ff2-\x1ff4\x1ff6\x1ff7\x210a\x210e\x210f\x2113\x212f\x2134\x2139\x213c\x213d\x2146-\x2149\x214e\x2184\x2c30-\x2c5e\x2c61\x2c65\x2c66\x2c68\x2c6a\x2c6c\x2c71\x2c73\x2c74\x2c76-\x2c7b\x2c81\x2c83\x2c85\x2c87\x2c89\x2c8b\x2c8d\x2c8f\x2c91\x2c93\x2c95\x2c97\x2c99\x2c9b\x2c9d\x2c9f\x2ca1\x2ca3\x2ca5\x2ca7\x2ca9\x2cab\x2cad\x2caf\x2cb1\x2cb3\x2cb5\x2cb7\x2cb9\x2cbb\x2cbd\x2cbf\x2cc1\x2cc3\x2cc5\x2cc7\x2cc9\x2ccb\x2ccd\x2ccf\x2cd1\x2cd3\x2cd5\x2cd7\x2cd9\x2cdb\x2cdd\x2cdf\x2ce1\x2ce3\x2ce4\x2cec\x2cee\x2cf3\x2d00-\x2d25\x2d27\x2d2d\xa641\xa643\xa645\xa647\xa649\xa64b\xa64d\xa64f\xa651\xa653\xa655\xa657\xa659\xa65b\xa65d\xa65f\xa661\xa663\xa665\xa667\xa669\xa66b\xa66d\xa681\xa683\xa685\xa687\xa689\xa68b\xa68d\xa68f\xa691\xa693\xa695\xa697\xa699\xa69b\xa723\xa725\xa727\xa729\xa72b\xa72d\xa72f-\xa731\xa733\xa735\xa737\xa739\xa73b\xa73d\xa73f\xa741\xa743\xa745\xa747\xa749\xa74b\xa74d\xa74f\xa751\xa753\xa755\xa757\xa759\xa75b\xa75d\xa75f\xa761\xa763\xa765\xa767\xa769\xa76b\xa76d\xa76f\xa771-\xa778\xa77a\xa77c\xa77f\xa781\xa783\xa785\xa787\xa78c\xa78e\xa791\xa793-\xa795\xa797\xa799\xa79b\xa79d\xa79f\xa7a1\xa7a3\xa7a5\xa7a7\xa7a9\xa7b5\xa7b7\xa7fa\xab30-\xab5a\xab60-\xab65\xab70-\xabbf\xfb00-\xfb06\xfb13-\xfb17\xff41-\xff5a\x10428-\x1044f\x104d8-\x104fb\x10cc0-\x10cf2\x118c0-\x118df\x1d41a-\x1d433\x1d44e-\x1d454\x1d456-\x1d467\x1d482-\x1d49b\x1d4b6-\x1d4b9\x1d4bb\x1d4bd-\x1d4c3\x1d4c5-\x1d4cf\x1d4ea-\x1d503\x1d51e-\x1d537\x1d552-\x1d56b\x1d586-\x1d59f\x1d5ba-\x1d5d3\x1d5ee-\x1d607\x1d622-\x1d63b\x1d656-\x1d66f\x1d68a-\x1d6a5\x1d6c2-\x1d6da\x1d6dc-\x1d6e1\x1d6fc-\x1d714\x1d716-\x1d71b\x1d736-\x1d74e\x1d750-\x1d755\x1d770-\x1d788\x1d78a-\x1d78f\x1d7aa-\x1d7c2\x1d7c4-\x1d7c9\x1d7cb\x1e922-\x1e943_]
+$alpha = [$small $large]
+
+$graphic = [$small $large $symbol $digit $special \:\"\']
+
+$octit = 0-7
+$hexit = [0-9 A-F a-f]
+$idchar = [$alpha $digit \']
+$symchar = [$symbol \:]
+$nl = [\n\r]
+
+@reservedid =
+ case|default|else|if|
+ infix|infixl|infixr|
+ then|family|foreign|export|dynamic|
+ safe|threadsafe|unsafe|stdcall|ccall|dotnet
+
+@varid = $small $idchar* [\#]?
+@conid = $large $idchar* [\#]?
+@anyid = (@varid | @conid)
+@anyTHid = [$small $large] [$alpha $digit]*
+@qual = (@conid ".")*
+@varsym = $symbol $symchar* | [⤜ ⤚ ⤛ ⤙ ★]
+@consym = \: $symchar*
+
+@decimal = $digit+
+@octal = $octit+
+@hexadecimal = $hexit+
+@exponent = [eE] [\-\+] @decimal
+
+$cntrl = [$large \@\[\\\]\^\_]
+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK
+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE
+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM
+ | SUB | ESC | FS | GS | RS | US | SP | DEL
+$charesc = [abfnrtv\\\"\'\&]
+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)
+@gap = \\ $whitechar+ \\
+@string = $graphic # [\"\\] | " " | @escape | @gap
+
+haskell :-
+
+<0> $white+ ;
+
+<nestcomm> {
+ "{-" { m (subtract 1) (Comment Open) }
+ "-}" { m (+1) (Comment Close) }
+ $white+ ; -- whitespace
+ [^\-\{]+ { c $ Comment Text } -- rule to generate comments larger than 1 char
+ . { c $ Comment Text }
+}
+
+<0> {
+-- The first rule matches operators that begin with --, eg --++-- is a valid
+-- operator and *not* a comment.
+-- Note that we have to dissallow '-' as a symbol char for the first one
+-- of these because we may have -------- which would stilljust be the
+-- start of a comment.
+ "--"\-* [$symbol # \-] $symchar* { cs Operator }
+-- The next rule allows for the start of a comment basically
+-- it is -- followed by anything which isn't a symbol character
+-- (OR more '-'s). So for example "-----:" is still the start of a comment.
+ "--"~[$symbol # \-][^$nl]* { c $ Comment Line }
+-- Finally because the above rule had to add in a non symbol character
+-- it's also possible that we have just finishing a line,
+-- people sometimes do this for example when breaking up paragraphs
+-- in a long comment.
+ "--"$nl { c $ Comment Line }
+
+ "{-" { m (subtract 1) $ Comment Open }
+
+ ^"#".* { c $ CppDirective }
+ $special { cs $ \(c:_) -> Special c }
+ "deriving" { c (Reserved Deriving) }
+ "forall" { c (Reserved Forall) }
+ "∀" { c (Reserved Forall) }
+ @reservedid { c (Reserved Other) }
+ "hiding" { c (Reserved Hiding) }
+ "module" { c (Reserved Module) }
+ "type" { c (Reserved Type) }
+ "newtype" { c (Reserved NewType) }
+ "as" { c (Reserved As) }
+ "import" { c (Reserved Import) }
+ "data" { c (Reserved Data) }
+ "where" { c (Reserved Where) }
+ "qualified" { c (Reserved Qualified) }
+ "let" { c (Reserved Let) }
+ "in" { c (Reserved In) }
+ "of" { c (Reserved Of) }
+ "do" | "mdo" { c (Reserved Do) }
+ "class" { c (Reserved Class) }
+ "instance" { c (Reserved Instance) }
+ `@qual @varid` { cs $ Operator . init . tail }
+ `@qual @conid` { cs $ ConsOperator . init . tail }
+ @qual @varid { c VarIdent }
+ @qual @conid { c ConsIdent }
+
+ "|" { c (ReservedOp Pipe) }
+ "=" { c (ReservedOp Equal) }
+ \\ { c (ReservedOp BackSlash) }
+ "<-" | "←" { c (ReservedOp LeftArrow) }
+ "->" | "→" { c (ReservedOp RightArrow) }
+ ".." { c (ReservedOp DoubleDot) }
+ "@" { c (ReservedOp Arobase) }
+ "~" { c (ReservedOp Tilda) }
+ "=>" | "⇒" { c (ReservedOp DoubleRightArrow) }
+ "::" | "∷" { c (ReservedOp DoubleColon) }
+ @qual @varsym { cs Operator }
+ @qual @consym { cs ConsOperator }
+
+ @decimal
+ | 0[oO] @octal
+ | 0[xX] @hexadecimal { c Number }
+
+ @decimal \. @decimal @exponent?
+ | @decimal @exponent { c Number }
+
+ \'\' @anyid { c THQuote } -- type
+ \' @anyTHid { c THQuote } -- expression
+ \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }
+ \" @string* \" { c StringTok }
+ . { c Unrecognized }
+}
+
+{
+
+type HlState = Int
+
+data CommentType = Open | Close | Text | Line
+ deriving (Eq, Show)
+
+data ReservedType = Hiding | Qualified | As | Import | Data | NewType | Type | Where
+ | Let | In | Do | Of | OtherLayout | Deriving | Module | Forall | Other | Class | Instance
+ deriving (Eq, Show)
+
+data OpType = Pipe | Equal | BackSlash | LeftArrow | RightArrow | DoubleRightArrow | DoubleColon | DoubleDot | Arobase | Tilda
+ deriving (Eq, Show)
+
+data Token = Number | CharTok | StringTok | VarIdent | ConsIdent
+ | Reserved !ReservedType | ReservedOp !OpType | Special Char
+ | ConsOperator String | Operator String
+ | Comment !CommentType
+ | THQuote
+ | CppDirective | Unrecognized
+ deriving (Eq, Show)
+
+tokenToStyle :: Token -> StyleName
+tokenToStyle tok = case tok of
+ CppDirective -> preprocessorStyle
+ Number -> numberStyle
+ CharTok -> stringStyle
+ StringTok -> stringStyle
+ VarIdent -> variableStyle
+ ConsIdent -> typeStyle
+ ReservedOp _ -> operatorStyle
+ Reserved Import -> importStyle
+ Reserved Qualified -> importStyle
+ Reserved As -> importStyle
+ Reserved Hiding -> importStyle
+ Reserved _ -> keywordStyle
+ Special _ -> defaultStyle
+ ConsOperator _ -> operatorStyle
+ Operator _ -> operatorStyle
+ Comment _ -> commentStyle
+ THQuote -> quoteStyle
+ Unrecognized -> errorStyle
+
+tokenToText :: Token -> Maybe String
+tokenToText (ReservedOp BackSlash) = Just "λ"
+tokenToText (ReservedOp RightArrow) = Just "→ "
+tokenToText (ReservedOp DoubleRightArrow) = Just "⇒ "
+tokenToText (ReservedOp LeftArrow) = Just "← "
+tokenToText (ReservedOp DoubleColon) = Just "∷ "
+-- missing: ++ >>=
+tokenToText (Operator "*") = Just "×"
+tokenToText (Operator "-") = Just "−"
+-- tokenToText (Operator "-->") = Just " ⟶ "
+tokenToText (Operator ".") = Just "·"
+tokenToText (Operator "/=") = Just "≠ "
+-- tokenToText (Operator "<--") = Just " ⟵ "
+tokenToText (Operator "<-|") = Just " ↤ "
+-- tokenToText (Operator "<<") = Just "⟪ "
+tokenToText (Operator "<|") = Just "◃ "
+tokenToText (Operator "<~") = Just "↜ "
+tokenToText (Operator "==") = Just "≡ "
+-- tokenToText (Operator "==>") = Just " ⟹ "
+tokenToText (Operator "=?") = Just "≟ "
+-- tokenToText (Operator ">>") = Just "⟫ "
+tokenToText (Operator "|-->") = Just " ⟼ "
+tokenToText (Operator "|->") = Just " ↦ "
+tokenToText (Operator "|>") = Just "▹ "
+tokenToText (Operator "~=") = Just "≃ "
+tokenToText (Operator "~>") = Just "↝ "
+tokenToText (Operator ">=") = Just "≥ "
+tokenToText (Operator "<=") = Just "≤ "
+tokenToText (Operator "-<") = Just "↢ "
+tokenToText (Operator "&&") = Just "∧ "
+tokenToText (Operator "||") = Just "∨ "
+{- these are not operators
+tokenToText (Operator "_|_") = Just " ⊥ "
+tokenToText (Operator "exists") = Just " ∃ "
+tokenToText (Operator "not") = Just " ¬ "
+tokenToText (Operator "neg") = Just " ¬ "
+-}
+tokenToText (Reserved Forall) = Just " ∀ "
+tokenToText _ = Nothing
+
+startsLayout (Reserved Do) = True
+startsLayout (Reserved Of) = True
+startsLayout (Reserved Where) = True
+startsLayout (Reserved Let) = True
+startsLayout (Reserved OtherLayout) = True
+startsLayout _ = False
+
+isComment (Comment _) = True
+isComment _ = False
+
+stateToInit x | x < 0 = nestcomm
+ | otherwise = 0
+
+initState :: HlState
+initState = 0
+
+type TT = Tok Token
+
+isSpecial :: String -> Token -> Bool
+isSpecial cs (Special c) = c `elem` cs
+isSpecial _ _ = False
+
+isErrorTok :: Token -> Bool
+isErrorTok = isSpecial "!"
+
+
+#include "common.hsinc"
+}
diff --git a/src/Yi/Lexer/LiterateHaskell.x b/src/Yi/Lexer/LiterateHaskell.x
new file mode 100644
index 0000000..ab89a1a
--- /dev/null
+++ b/src/Yi/Lexer/LiterateHaskell.x
@@ -0,0 +1,224 @@
+-- -*- haskell -*-
+--
+-- Lexical syntax for literate Haskell 98.
+--
+-- (c) Simon Marlow 2003, with the caveat that much of this is
+-- translated directly from the syntax in the Haskell 98 report.
+--
+-- Adapted to literate Haskell 98 by Nicolas Pouillard
+--
+
+{
+{-# OPTIONS -w #-}
+module Yi.Lexer.LiterateHaskell ( initState, alexScanToken, HlState ) where
+import Yi.Lexer.Alex hiding (tokenToStyle)
+import Yi.Lexer.Haskell hiding (initState, alexScanToken, HlState)
+import Yi.Style
+}
+
+$whitechar = [\ \t\n\r\f\v]
+$special = [\(\)\,\;\[\]\`\{\}]
+
+$ascdigit = 0-9
+$unidigit = [] -- TODO
+$digit = [$ascdigit $unidigit]
+
+$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~]
+$unisymbol = [] -- TODO
+$symbol = [$ascsymbol $unisymbol] # [$special \_\:\"\']
+
+$large = [A-Z \xc0-\xd6 \xd8-\xde]
+$small = [a-z \xdf-\xf6 \xf8-\xff \_]
+$alpha = [$small $large]
+
+$graphic = [$small $large $symbol $digit $special \:\"\']
+
+$octit = 0-7
+$hexit = [0-9 A-F a-f]
+$idchar = [$alpha $digit \']
+$symchar = [$symbol \:]
+$nl = [\n\r]
+
+@reservedid =
+ as|case|class|data|default|else|hiding|if|
+ import|in|infix|infixl|infixr|instance|newtype|
+ qualified|then|type|family|foreign|export|dynamic|
+ safe|threadsafe|unsafe|stdcall|ccall|dotnet
+
+@layoutReservedId =
+ of|let|do|mdo
+
+
+@reservedop =
+ ".." | ":" | "::" | "=" | \\ | "|" | "<-" | "->" | "@" | "~" | "=>"
+
+@varid = $small $idchar*
+@conid = $large $idchar*
+@qual = (@conid ".")*
+@varsym = $symbol $symchar*
+@consym = \: $symchar*
+
+@decimal = $digit+
+@octal = $octit+
+@hexadecimal = $hexit+
+@exponent = [eE] [\-\+] @decimal
+
+$cntrl = [$large \@\[\\\]\^\_]
+@ascii = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK
+ | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE
+ | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM
+ | SUB | ESC | FS | GS | RS | US | SP | DEL
+$charesc = [abfnrtv\\\"\'\&]
+@escape = \\ ($charesc | @ascii | @decimal | o @octal | x @hexadecimal)
+@gap = \\ $whitechar+ \\
+@string = $graphic # [\"\\] | " " | @escape | @gap
+
+haskell :-
+
+<0> $white+ ;
+
+<nestcomm> {
+ "{-" { m CommentBlock (Comment Open) }
+ "-}" { m unComment (Comment Close) }
+ $white+ ; -- whitespace
+ [^\-\{]+ { c $ Comment Text } -- rule to generate comments larger than 1 char
+ . { c $ Comment Text }
+}
+
+<0> {
+ ^ "\begin{code}" { m (const CodeBlock) $ Reserved Other }
+ ^ ">" { ms (const CodeLine) Operator }
+ $white+ ; -- whitespace
+ . { c $ Comment Text {-LaTeX-} }
+}
+
+<codeBlock> {
+ "\end{code}" { m (const LaTeXBlock) $ Reserved Other }
+
+ $white+ ; -- whitespace
+
+-- The first rule matches operators that begin with --, eg --++-- is a valid
+-- operator and *not* a comment.
+-- Note that we have to dissallow '-' as a symbol char for the first one
+-- of these because we may have -------- which would stilljust be the
+-- start of a comment.
+ "--"\-* [$symbol # \-] $symchar* { cs Operator }
+-- The next rule allows for the start of a comment basically
+-- it is -- followed by anything which isn't a symbol character
+-- (OR more '-'s). So for example "-----:" is still the start of a comment.
+ "--"~[$symbol # \-][^$nl]* { c $ Comment Line }
+-- Finally because the above rule had to add in a non symbol character
+-- it's also possible that we have just finishing a line,
+-- people sometimes do this for example when breaking up paragraphs
+-- in a long comment.
+ "--"$nl { c $ Comment Line }
+
+ "{-" { m CommentBlock $ Comment Open }
+
+ ^"#".* { c $ CppDirective }
+ $special { cs $ \(c:_) -> Special c }
+ "deriving" { c (Reserved Deriving) }
+ "forall" { c (Reserved Forall) }
+ @reservedid { c (Reserved Other) }
+ "module" { c (Reserved Module) }
+ "where" { c (Reserved Where) }
+ @layoutReservedId { c (Reserved OtherLayout) }
+ `@qual @varid` { cs $ Operator . init . tail }
+ `@qual @conid` { cs $ ConsOperator . init . tail }
+ @qual @varid { c VarIdent }
+ @qual @conid { c ConsIdent }
+
+ "|" { c (ReservedOp Pipe) }
+ "=" { c (ReservedOp Equal) }
+ \\ { c (ReservedOp BackSlash) }
+ "<-" { c (ReservedOp LeftArrow) }
+ "->" { c (ReservedOp RightArrow) }
+ "=>" { c (ReservedOp DoubleRightArrow) }
+ ".." { c (ReservedOp DoubleDot) }
+ "@" { c (ReservedOp Arobase) }
+ "~" { c (ReservedOp Tilda) }
+ "=>" { c (ReservedOp DoubleRightArrow) }
+ "::" { c (ReservedOp DoubleColon) }
+ @qual @varsym { cs Operator }
+ @qual @consym { cs ConsOperator }
+
+ @decimal
+ | 0[oO] @octal
+ | 0[xX] @hexadecimal { c Number }
+
+ @decimal \. @decimal @exponent?
+ | @decimal @exponent { c Number }
+
+ \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }
+ \" @string* \" { c StringTok }
+ . { c Unrecognized }
+}
+
+<codeLine> {
+ [\t\n\r\f\v]+ { m (const LaTeXBlock) $ Reserved Other }
+
+ [\ \t]+ ; -- whitespace
+
+-- Same three rules for line comments as above (see above for explanation).
+ "--"\-* [$symbol # \-] $symchar* { cs Operator }
+ "--"~[$symbol # \-][^$nl]* { c $ Comment Line }
+ "--"$nl { c $ Comment Line }
+
+ "{-" { m CommentBlock $ Comment Open }
+
+ ^"#".* { c $ CppDirective }
+ $special { cs $ \(c:_) -> Special c }
+ "deriving" { c (Reserved Deriving) }
+ "forall" { c (Reserved Forall) }
+ @reservedid { c (Reserved Other) }
+ "module" { c (Reserved Module) }
+ "where" { c (Reserved Where) }
+ @layoutReservedId { c (Reserved OtherLayout) }
+ `@qual @varid` { cs $ Operator . init . tail }
+ `@qual @conid` { cs $ ConsOperator . init . tail }
+ @qual @varid { c VarIdent }
+ @qual @conid { c ConsIdent }
+
+ "|" { c (ReservedOp Pipe) }
+ "=" { c (ReservedOp Equal) }
+ \\ { c (ReservedOp BackSlash) }
+ "<-" { c (ReservedOp LeftArrow) }
+ "->" { c (ReservedOp RightArrow) }
+ "=>" { c (ReservedOp DoubleRightArrow) }
+ ".." { c (ReservedOp DoubleDot) }
+ "@" { c (ReservedOp Arobase) }
+ "~" { c (ReservedOp Tilda) }
+ "=>" { c (ReservedOp DoubleRightArrow) }
+ "::" { c (ReservedOp DoubleColon) }
+ @qual @varsym { cs Operator }
+ @qual @consym { cs ConsOperator }
+
+ @decimal
+ | 0[oO] @octal
+ | 0[xX] @hexadecimal { c Number }
+
+ @decimal \. @decimal @exponent?
+ | @decimal @exponent { c Number }
+
+ \' ($graphic # [\'\\] | " " | @escape) \' { c CharTok }
+ \" @string* \" { c StringTok }
+ . { c Unrecognized }
+}
+
+{
+
+data HlState = CodeBlock
+ | CodeLine
+ | CommentBlock { unComment :: HlState }
+ | LaTeXBlock
+ deriving (Eq, Show)
+
+stateToInit (CommentBlock _) = nestcomm
+stateToInit CodeBlock = codeBlock
+stateToInit CodeLine = codeLine
+stateToInit LaTeXBlock = 0
+
+initState = LaTeXBlock
+
+#include "common.hsinc"
+}
diff --git a/src/Yi/Mode/GHCi.hs b/src/Yi/Mode/GHCi.hs
new file mode 100644
index 0000000..ed1f6cf
--- /dev/null
+++ b/src/Yi/Mode/GHCi.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- |
+-- Module : Yi.Mode.GHCi
+-- License : GPL-2
+-- Maintainer : yi-devel@googlegroups.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- A mode for GHCi, implemented as tweaks on Interaction mode
+
+module Yi.Mode.GHCi where
+
+import GHC.Generics (Generic)
+
+import Lens.Micro.Platform (makeLenses, (%~), (&), (.~))
+import Data.Binary (Binary (..))
+import Data.Default (Default (..))
+import Data.Text ()
+import qualified Data.Text as T (findIndex)
+import Data.Typeable (Typeable)
+import Yi.Buffer
+import Yi.Keymap (YiM, topKeymapA)
+import Yi.Keymap.Keys (Key (KHome), important, spec, (?>>!))
+import Yi.Lexer.Alex (Tok)
+import Yi.Lexer.Compilation (Token ())
+import qualified Yi.Mode.Interactive as I (mode, spawnProcessMode)
+import qualified Yi.Rope as R (toText)
+import Yi.Syntax.OnlineTree (Tree)
+import Yi.Types (YiVariable)
+
+-- | The process name to use to spawn GHCi.
+data GhciProcessName = GhciProcessName
+ { _ghciProcessName :: FilePath
+ -- ^ Command to run when spawning GHCi.
+ , _ghciProcessArgs :: [String]
+ -- ^ Args to pass to the process.
+ } deriving (Typeable, Show, Generic)
+
+-- | The process name defaults to @ghci@.
+instance Default GhciProcessName where
+ def = GhciProcessName { _ghciProcessName = "ghci"
+ , _ghciProcessArgs = []
+ }
+
+instance Binary GhciProcessName
+
+makeLenses ''GhciProcessName
+
+-- | Setting this is a bit like '(setq haskell-program-name foo)' in
+-- emacs' @haskell-mode@.
+instance YiVariable GhciProcessName
+
+-- | Mode used for GHCi. Currently it just overrides 'KHome' key to go
+-- just before the prompt through the use of 'homeKey'.
+mode :: Mode (Tree (Tok Token))
+mode = I.mode
+ & modeNameA .~ "ghci"
+ & modeKeymapA .~ topKeymapA %~ important (spec KHome ?>>! homeKey)
+
+-- | The GHCi prompt always begins with ">"; this goes to just before
+-- it, or if one is already at the start of the prompt, goes to the
+-- beginning of the line. (If at the beginning of the line, this
+-- pushes you forward to it.)
+homeKey :: BufferM ()
+homeKey = readLnB >>= \l -> case T.findIndex ('>' ==) (R.toText l) of
+ Nothing -> moveToSol
+ Just pos -> do
+ (_,mypos) <- getLineAndCol
+ moveToSol >> if mypos == (pos + 2)
+ then return ()
+ else moveXorEol (pos + 2)
+
+-- | Spawns an interactive process ("Yi.Mode.Interactive") with GHCi
+-- 'mode' over it.
+spawnProcess :: FilePath -- ^ Command to use.
+ -> [String] -- ^ Process args.
+ -> YiM BufferRef -- ^ Reference to the spawned buffer.
+spawnProcess = I.spawnProcessMode mode
diff --git a/src/Yi/Mode/Haskell.hs b/src/Yi/Mode/Haskell.hs
new file mode 100644
index 0000000..295b706
--- /dev/null
+++ b/src/Yi/Mode/Haskell.hs
@@ -0,0 +1,470 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- |
+-- Module : Yi.Mode.Haskell
+-- License : GPL-2
+-- Maintainer : yi-devel@googlegroups.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Collection of 'Mode's for working with Haskell.
+
+module Yi.Mode.Haskell
+ (
+ -- * Modes
+ haskellAbstract,
+ cleverMode,
+ preciseMode,
+ literateMode,
+ fastMode,
+
+ -- * IO-level operations
+ ghciGet,
+ ghciSend,
+ ghciLoadBuffer,
+ ghciInferType,
+ ghciSetProcessName,
+ ghciSetProcessArgs
+ ) where
+
+import Prelude hiding (all, concatMap, elem, error, notElem, exp)
+
+import Lens.Micro.Platform ((&), (.~), (^.))
+import Control.Monad (unless, void, when)
+import Data.Binary (Binary)
+import Data.Default (Default)
+import Data.Foldable (all, concatMap, elem, forM_, notElem)
+import Data.Maybe (isJust, listToMaybe)
+import Data.Monoid ((<>))
+import qualified Data.Text as T (any, concat, drop, pack, unpack, unwords)
+import Data.Typeable (Typeable)
+import Text.Read (readMaybe)
+import Yi.Buffer
+import Yi.Core (sendToProcess)
+import Yi.Debug (error, trace)
+import Yi.Editor
+import Yi.File (fwriteE)
+import qualified Yi.IncrementalParse as IncrParser (State, scanner)
+import Yi.Keymap (YiM)
+import Yi.Lexer.Alex
+import Yi.Lexer.Haskell as Haskell
+import qualified Yi.Lexer.LiterateHaskell as LiterateHaskell (HlState, alexScanToken, initState)
+import Yi.MiniBuffer (noHint, withMinibufferFree, withMinibufferGen)
+import qualified Yi.Mode.GHCi as GHCi (ghciProcessArgs, ghciProcessName, spawnProcess)
+import qualified Yi.Mode.Interactive as Interactive (queryReply)
+import Yi.Mode.Common (anyExtension, extensionOrContentsMatch, shebangParser)
+import Yi.Monad (gets)
+import qualified Yi.Rope as R
+import Yi.String (fillText, showT)
+import Yi.Syntax (ExtHL (..), Scanner, skipScanner)
+import qualified Yi.Syntax.Driver as Driver (mkHighlighter)
+import Yi.Syntax.Haskell as Hask
+import Yi.Syntax.Layout (State)
+import Yi.Syntax.OnlineTree as OnlineTree (Tree, manyToks)
+import Yi.Syntax.Paren as Paren
+import Yi.Syntax.Strokes.Haskell as HS (getStrokes)
+import Yi.Syntax.Tree
+import Yi.Types (YiVariable)
+import Yi.Utils (groupBy')
+
+-- | General ‘template’ for actual Haskell modes.
+--
+-- It applies over @extensions = ["hs", "x", "hsc", "hsinc"]@ which
+-- may be a little questionable but for now Yi is mostly used by
+-- Haskell hackers so it should be fine, at least for now.
+haskellAbstract :: Mode (tree TT)
+haskellAbstract = emptyMode
+ & modeAppliesA .~ extensionOrContentsMatch extensions (shebangParser "runhaskell")
+ & modeNameA .~ "haskell"
+ & modeToggleCommentSelectionA .~ Just (toggleCommentB "--")
+ where extensions = ["hs", "x", "hsc", "hsinc"]
+
+-- | "Clever" haskell mode, using the paren-matching syntax.
+cleverMode :: Mode (Paren.Tree (Tok Haskell.Token))
+cleverMode = haskellAbstract
+ & modeIndentA .~ cleverAutoIndentHaskellB
+ & modeGetStrokesA .~ strokesOfParenTree
+ & modeHLA .~ mkParenModeHL (skipScanner 50) haskellLexer
+ & modeAdjustBlockA .~ adjustBlock
+ & modePrettifyA .~ cleverPrettify . allToks
+
+fastMode :: Mode (OnlineTree.Tree TT)
+fastMode = haskellAbstract
+ & modeNameA .~ "fast haskell"
+ & modeHLA .~ mkOnlineModeHL haskellLexer
+ & modeGetStrokesA .~ tokenBasedStrokes Paren.tokenToStroke
+
+literateMode :: Mode (Paren.Tree TT)
+literateMode = haskellAbstract
+ & modeNameA .~ "literate haskell"
+ & modeAppliesA .~ anyExtension ["lhs"]
+ & modeHLA .~ mkParenModeHL id literateHaskellLexer
+ & modeGetStrokesA .~ strokesOfParenTree
+ -- FIXME I think that 'begin' should not be ignored
+ & modeAdjustBlockA .~ adjustBlock
+ & modeIndentA .~ cleverAutoIndentHaskellB
+ & modePrettifyA .~ cleverPrettify . allToks
+
+-- | Experimental Haskell mode, using a rather precise parser for the syntax.
+preciseMode :: Mode (Hask.Tree TT)
+preciseMode = haskellAbstract
+ & modeNameA .~ "precise haskell"
+ & modeIndentA .~ cleverAutoIndentHaskellC
+ & modeGetStrokesA .~ (\ast point begin end -> HS.getStrokes point begin end ast)
+ & modeHLA .~ mkHaskModeHL haskellLexer
+ & modePrettifyA .~ cleverPrettify . allToks
+--
+strokesOfParenTree :: Paren.Tree TT -> Point -> Point -> Point -> [Stroke]
+strokesOfParenTree t p b e = Paren.getStrokes p b e t
+
+type CharToTTScanner s = CharScanner -> Scanner (AlexState s) TT
+
+mkParenModeHL :: (IsTree tree, Show state)
+ => (Scanner
+ (IncrParser.State (State Token lexState) TT (Paren.Tree TT))
+ (Paren.Tree TT)
+ -> Scanner state (tree (Tok tt)))
+ -> CharToTTScanner lexState
+ -> ExtHL (tree (Tok tt))
+mkParenModeHL f l = ExtHL $ Driver.mkHighlighter scnr
+ where
+ scnr = f . IncrParser.scanner Paren.parse . Paren.indentScanner . l
+
+mkHaskModeHL :: Show st => CharToTTScanner st -> ExtHL (Exp (Tok Token))
+mkHaskModeHL l = ExtHL $ Driver.mkHighlighter scnr
+ where
+ scnr = IncrParser.scanner Hask.parse . Hask.indentScanner . l
+
+mkOnlineModeHL :: Show st => (CharScanner -> Scanner st (Tok tt))
+ -> ExtHL (OnlineTree.Tree (Tok tt))
+mkOnlineModeHL l = ExtHL $ Driver.mkHighlighter scnr
+ where
+ scnr = IncrParser.scanner OnlineTree.manyToks . l
+
+haskellLexer :: CharScanner -> Scanner (AlexState Haskell.HlState) TT
+haskellLexer = lexScanner (commonLexer Haskell.alexScanToken Haskell.initState)
+
+literateHaskellLexer :: CharScanner -> Scanner (AlexState LiterateHaskell.HlState) TT
+literateHaskellLexer = lexScanner (commonLexer LiterateHaskell.alexScanToken LiterateHaskell.initState)
+
+adjustBlock :: Paren.Tree (Tok Token) -> Int -> BufferM ()
+adjustBlock e len = do
+ p <- pointB
+ l <- curLn
+ let t = Paren.getIndentingSubtree e p l
+ case t of
+ Nothing -> return ()
+ Just it -> savingExcursionB $ do
+ let (_startOfs, height) = Paren.getSubtreeSpan it
+ col <- curCol
+ forM_ [1..height] $ const $ do
+ lineDown
+ indent <- indentOfB =<< readLnB
+ -- it might be that we have 1st column comments in the block,
+ -- which should not be changed.
+ when (indent > col) $
+ if len >= 0
+ then do
+ insertN $ R.replicateChar len ' '
+ leftN len
+ else deleteN (negate len)
+
+-- | Returns true if the token should be indented to look as "inside"
+-- the group.
+insideGroup :: Token -> Bool
+insideGroup (Special c) = T.any (== c) "',;})]"
+insideGroup _ = True
+
+-- | Helper method for taking information needed for both Haskell auto-indenters:
+indentInfoB :: BufferM (Int, Int, Int, Point, Point)
+indentInfoB = do
+ indentLevel <- shiftWidth <$> indentSettingsB
+ previousIndent <- indentOfB =<< getNextNonBlankLineB Backward
+ nextIndent <- indentOfB =<< getNextNonBlankLineB Forward
+ solPnt <- pointAt moveToSol
+ eolPnt <- pointAt moveToEol
+ return (indentLevel, previousIndent, nextIndent, solPnt, eolPnt)
+
+cleverAutoIndentHaskellB :: Paren.Tree TT -> IndentBehaviour -> BufferM ()
+cleverAutoIndentHaskellB e behaviour = do
+ (indentLevel, previousIndent, nextIndent, solPnt, eolPnt) <- indentInfoB
+ let onThisLine ofs = ofs >= solPnt && ofs <= eolPnt
+ firstTokNotOnLine = listToMaybe .
+ filter (not . onThisLine . posnOfs . tokPosn) .
+ filter (not . isErrorTok . tokT) . concatMap allToks
+ let stopsOf :: [Paren.Tree TT] -> [Int]
+ stopsOf (g@(Paren.Paren open ctnt close):ts')
+ | isErrorTok (tokT close) || getLastOffset g >= solPnt
+ = [groupIndent open ctnt] -- stop here: we want to be "inside" that group.
+ | otherwise = stopsOf ts' -- this group is closed before this line; just skip it.
+ stopsOf (Paren.Atom (Tok {tokT = t}):_) | startsLayout t = [nextIndent, previousIndent + indentLevel]
+ -- of; where; etc. we want to start the block here.
+ -- Also use the next line's indent:
+ -- maybe we are putting a new 1st statement in the block here.
+ stopsOf (Paren.Atom _:ts) = stopsOf ts
+ -- any random part of expression, we ignore it.
+ stopsOf (t@(Paren.Block _):ts) = shiftBlock + maybe 0 (posnCol . tokPosn) (getFirstElement t) : stopsOf ts
+ stopsOf (_:ts) = stopsOf ts
+ stopsOf [] = []
+ firstTokOnLine = fmap tokT $ listToMaybe $
+ dropWhile ((solPnt >) . tokBegin) $
+ takeWhile ((eolPnt >) . tokBegin) $ -- for laziness.
+ filter (not . isErrorTok . tokT) $ allToks e
+ shiftBlock = case firstTokOnLine of
+ Just (Reserved t) | t `elem` [Where, Deriving] -> indentLevel
+ Just (ReservedOp Haskell.Pipe) -> indentLevel
+ Just (ReservedOp Haskell.Equal) -> indentLevel
+ _ -> 0
+ deepInGroup = maybe True insideGroup firstTokOnLine
+ groupIndent (Tok {tokT = Special openChar, tokPosn = Posn _ _ openCol}) ctnt
+ | deepInGroup = case firstTokNotOnLine ctnt of
+ -- examine the first token of the group (but not on the line we are indenting!)
+ Nothing -> openCol + nominalIndent openChar -- no such token: indent normally.
+ Just t -> posnCol . tokPosn $ t -- indent along that other token
+ | otherwise = openCol
+ groupIndent (Tok {}) _ = error "unable to indent code"
+ case getLastPath [e] solPnt of
+ Nothing -> return ()
+ Just path -> let stops = stopsOf path
+ in trace ("Stops = " <> showT stops) $
+ trace ("firstTokOnLine = " <> showT firstTokOnLine) $
+ cycleIndentsB behaviour stops
+
+cleverAutoIndentHaskellC :: Exp TT -> IndentBehaviour -> BufferM ()
+cleverAutoIndentHaskellC e behaviour = do
+ (indentLevel, previousIndent, nextIndent, solPnt, eolPnt) <- indentInfoB
+ let onThisLine ofs = ofs >= solPnt && ofs <= eolPnt
+ firstTokNotOnLine = listToMaybe .
+ filter (not . onThisLine . posnOfs . tokPosn) .
+ filter (not . isErrorTok . tokT) . concatMap allToks
+ let stopsOf :: [Hask.Exp TT] -> [Int]
+ stopsOf (g@(Hask.Paren (Hask.PAtom open _) ctnt (Hask.PAtom close _)):ts)
+ | isErrorTok (tokT close) || getLastOffset g >= solPnt
+ = [groupIndent open ctnt]
+ -- stop here: we want to be "inside" that group.
+ | otherwise = stopsOf ts
+ -- this group is closed before this line; just skip it.
+ stopsOf (Hask.PAtom (Tok {tokT = t}) _:_) | startsLayout t || (t == ReservedOp Equal)
+ = [nextIndent, previousIndent + indentLevel]
+ -- of; where; etc. ends the previous line. We want to start the block here.
+ -- Also use the next line's indent:
+ -- maybe we are putting a new 1st statement in the block here.
+ stopsOf (l@(Hask.PLet _ (Hask.Block _) _):ts') = [colOf' l | lineStartsWith (Reserved Haskell.In)] <> stopsOf ts'
+ -- offer to align with let only if this is an "in"
+ stopsOf (t@(Hask.Block _):ts') = (shiftBlock + colOf' t) : stopsOf ts'
+ -- offer add another statement in the block
+ stopsOf (Hask.PGuard' (PAtom pipe _) _ _:ts') = [tokCol pipe | lineStartsWith (ReservedOp Haskell.Pipe)] <> stopsOf ts'
+ -- offer to align against another guard
+ stopsOf (d@(Hask.PData {}):ts') = colOf' d + indentLevel
+ : stopsOf ts' --FIXME!
+ stopsOf (Hask.RHS (Hask.PAtom{}) exp:ts')
+ = [case firstTokOnLine of
+ Just (Operator op') -> opLength op' (colOf' exp) -- Usually operators are aligned against the '=' sign
+ -- case of an operator should check so that value always is at least 1
+ _ -> colOf' exp | lineIsExpression ] <> stopsOf ts'
+ -- offer to continue the RHS if this looks like an expression.
+ stopsOf [] = [0] -- maybe it's new declaration in the module
+ stopsOf (_:ts) = stopsOf ts -- by default, there is no reason to indent against an expression.
+ -- calculate indentation of operator (must be at least 1 to be valid)
+ opLength ts' r = let l = r - (length ts' + 1) -- I find this dubious...
+ in if l > 0 then l else 1
+
+ lineStartsWith tok = firstTokOnLine == Just tok
+ lineIsExpression = all (`notElem` [ReservedOp Haskell.Pipe, ReservedOp Haskell.Equal, ReservedOp RightArrow]) toksOnLine
+ && not (lineStartsWith (Reserved Haskell.In))
+ -- TODO: check the tree instead of guessing by looking at tokens
+ firstTokOnLine = listToMaybe toksOnLine
+ toksOnLine = fmap tokT $
+ dropWhile ((solPnt >) . tokBegin) $
+ takeWhile ((eolPnt >) . tokBegin) $ -- for laziness.
+ filter (not . isErrorTok . tokT) $ allToks e
+ shiftBlock = case firstTokOnLine of
+ Just (Reserved t) | t `elem` [Where, Deriving] -> indentLevel
+ Just (ReservedOp Haskell.Pipe) -> indentLevel
+ Just (ReservedOp Haskell.Equal) -> indentLevel
+ _ -> 0
+ deepInGroup = maybe True insideGroup firstTokOnLine
+ groupIndent (Tok {tokT = Special openChar, tokPosn = Posn _ _ openCol}) ctnt
+ | deepInGroup = case firstTokNotOnLine ctnt of
+ -- examine the first token of the group
+ -- (but not on the line we are indenting!)
+ Nothing -> openCol + nominalIndent openChar
+ -- no such token: indent normally.
+ Just t -> posnCol . tokPosn $ t -- indent along that other token
+ | otherwise = openCol
+ groupIndent (Tok{}) _ = error "unable to indent code"
+ case getLastPath [e] solPnt of
+ Nothing -> return ()
+ Just path ->let stops = stopsOf path
+ in trace ("Path = " <> showT path) $
+ trace ("Stops = " <> showT stops) $
+ trace ("Previous indent = " <> showT previousIndent) $
+ trace ("Next indent = " <> showT nextIndent) $
+ trace ("firstTokOnLine = " <> showT firstTokOnLine) $
+ cycleIndentsB behaviour stops
+
+colOf' :: Foldable t => t TT -> Int
+colOf' = maybe 0 tokCol . getFirstElement
+
+tokCol :: Tok t -> Int
+tokCol = posnCol . tokPosn
+
+
+nominalIndent :: Char -> Int
+nominalIndent '{' = 2
+nominalIndent _ = 1
+
+tokText :: Tok t -> BufferM R.YiString
+tokText = readRegionB . tokRegion
+
+tokRegion :: Tok t -> Region
+tokRegion t = mkRegion (tokBegin t) (tokEnd t)
+
+isLineComment :: TT -> Bool
+isLineComment = (Just Haskell.Line ==) . tokTyp . tokT
+
+contiguous :: Tok t -> Tok t -> Bool
+contiguous a b = lb - la <= 1
+ where [la,lb] = fmap (posnLine . tokPosn) [a,b]
+
+coalesce :: Tok Token -> Tok Token -> Bool
+coalesce a b = isLineComment a && isLineComment b && contiguous a b
+
+cleverPrettify :: [TT] -> BufferM ()
+cleverPrettify toks = do
+ pnt <- pointB
+ let groups = groupBy' coalesce toks
+ isCommentGroup g = tokTyp (tokT $ head g) `elem` fmap Just [Haskell.Line]
+ thisCommentGroup = listToMaybe $ dropWhile ((pnt >) . tokEnd . last) $ filter isCommentGroup groups
+ -- FIXME: laziness
+ case thisCommentGroup of
+ Nothing -> return ()
+ Just g -> do
+ text <- T.unwords . fmap (T.drop 2 . R.toText) <$> mapM tokText g
+ let region = mkRegion (tokBegin . head $ g) (tokEnd . last $ g)
+ mkGrp = const . R.unlines $ R.append "-- " <$> fillText 80 (R.fromText text)
+ modifyRegionB mkGrp region
+
+tokTyp :: Token -> Maybe Haskell.CommentType
+tokTyp (Comment t) = Just t
+tokTyp _ = Nothing
+
+-- TODO: export or remove
+-- -- Keyword-based auto-indenter for haskell.
+-- autoIndentHaskellB :: IndentBehaviour -> BufferM ()
+-- autoIndentHaskellB =
+-- autoIndentWithKeywordsB [ "if"
+-- , "then"
+-- , "else"
+-- , "|"
+-- , "->"
+-- , "case" -- hmm
+-- , "in"
+-- -- Note tempted by having '=' in here that would
+-- -- potentially work well for 'data' declarations
+-- -- but I think '=' is so common in other places
+-- -- that it would introduce many spurious/annoying
+-- -- hints.
+-- ]
+-- [ "where"
+-- , "let"
+-- , "do"
+-- , "mdo"
+-- , "{-"
+-- , "{-|"
+-- , "--"
+-- ]
+--
+---------------------------
+-- * Interaction with GHCi
+
+-- | Variable storing the possibe buffer reference where GHCi is
+-- currently running.
+newtype GhciBuffer = GhciBuffer {_ghciBuffer :: Maybe BufferRef}
+ deriving (Default, Typeable, Binary)
+
+instance YiVariable GhciBuffer
+
+-- | Start GHCi in a buffer
+ghci :: YiM BufferRef
+ghci = do
+ g <- getEditorDyn
+ b <- GHCi.spawnProcess (g ^. GHCi.ghciProcessName) (g ^. GHCi.ghciProcessArgs)
+ withEditor . putEditorDyn . GhciBuffer $ Just b
+ return b
+
+-- | Return GHCi's buffer; create it if necessary.
+-- Show it in another window.
+ghciGet :: YiM BufferRef
+ghciGet = withOtherWindow $ do
+ GhciBuffer mb <- withEditor getEditorDyn
+ case mb of
+ Nothing -> ghci
+ Just b -> do
+ stillExists <- isJust <$> findBuffer b
+ if stillExists
+ then do withEditor $ switchToBufferE b
+ return b
+ else ghci
+
+-- | Send a command to GHCi
+ghciSend :: String -> YiM ()
+ghciSend cmd = do
+ b <- ghciGet
+ withGivenBuffer b botB
+ sendToProcess b (cmd <> "\n")
+
+-- | Load current buffer in GHCi
+ghciLoadBuffer :: YiM ()
+ghciLoadBuffer = do
+ void fwriteE
+ f <- withCurrentBuffer (gets file)
+ case f of
+ Nothing -> error "Couldn't get buffer filename in ghciLoadBuffer"
+ Just filename -> ghciSend $ ":load " <> show filename
+
+-- Tells ghci to infer the type of the identifier at point. Doesn't
+-- check for errors (yet)
+ghciInferType :: YiM ()
+ghciInferType = do
+ nm <- withCurrentBuffer (readUnitB unitWord)
+ unless (R.null nm) $
+ withMinibufferGen (R.toText nm) noHint "Insert type of which identifier?"
+ return (const $ return ()) (ghciInferTypeOf . R.fromText)
+
+ghciInferTypeOf :: R.YiString -> YiM ()
+ghciInferTypeOf nm = do
+ buf <- ghciGet
+ result <- Interactive.queryReply buf (":t " <> R.toString nm)
+ let successful = (not . R.null) nm && nm == result
+ when successful . withCurrentBuffer $
+ moveToSol *> insertB '\n' *> leftB
+ *> insertN result *> rightB
+
+ghciSetProcessName :: YiM ()
+ghciSetProcessName = do
+ g <- getEditorDyn
+ let nm = g ^. GHCi.ghciProcessName
+ prompt = T.concat [ "Command to call for GHCi, currently ‘"
+ , T.pack nm, "’: " ]
+ withMinibufferFree prompt $ \s ->
+ putEditorDyn $ g & GHCi.ghciProcessName .~ T.unpack s
+
+ghciSetProcessArgs :: YiM ()
+ghciSetProcessArgs = do
+ g <- getEditorDyn
+ let nm = g ^. GHCi.ghciProcessName
+ args = g ^. GHCi.ghciProcessArgs
+ prompt = T.unwords [ "List of args to call "
+ , T.pack nm
+ , "with, currently"
+ , T.pack $ show args
+ , ":"
+ ]
+ withMinibufferFree prompt $ \arg ->
+ case readMaybe $ T.unpack arg of
+ Nothing -> printMsg "Could not parse as [String], keep old args."
+ Just arg' -> putEditorDyn $ g & GHCi.ghciProcessArgs .~ arg'
diff --git a/src/Yi/Mode/Haskell/Dollarify.hs b/src/Yi/Mode/Haskell/Dollarify.hs
new file mode 100644
index 0000000..d47cd70
--- /dev/null
+++ b/src/Yi/Mode/Haskell/Dollarify.hs
@@ -0,0 +1,186 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- |
+-- Module : Yi.Mode.Haskell.Dollarify
+-- License : GPL-2
+-- Maintainer : yi-devel@googlegroups.com
+-- Stability : experimental
+-- Portability : portable
+
+module Yi.Mode.Haskell.Dollarify where
+
+import Control.Monad (unless)
+import Data.Function (on)
+import Data.List (sortBy)
+import Data.Maybe (fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text ()
+import Yi.Buffer hiding (Block)
+import Yi.Debug (trace)
+import Yi.Lexer.Alex (Tok (..), posnOfs)
+import Yi.Lexer.Haskell (TT, Token (..), isComment)
+import qualified Yi.Rope as R (YiString, null)
+import Yi.String (showT)
+import qualified Yi.Syntax.Haskell as H (Exp (..), Tree)
+import Yi.Syntax.Paren (Expr, Tree (..))
+import Yi.Syntax.Tree (getAllSubTrees, getFirstOffset, getLastOffset, getLastPath)
+
+dollarify :: Tree TT -> BufferM ()
+dollarify t = maybe (return ()) dollarifyWithin . selectedTree [t] =<< getSelectRegionB
+
+dollarifyWithin :: Tree TT -> BufferM ()
+dollarifyWithin = trace . ("dollarifyWithin: " <>) . showT <*> runQ . (dollarifyTop =<<) . getAllSubTrees
+
+data QueuedUpdate = QueuedUpdate { qUpdatePoint :: Point
+ , qInsert :: R.YiString
+ , qDelete :: Int
+ } deriving (Eq, Ord, Show)
+
+runQ :: [QueuedUpdate] -> BufferM ()
+runQ = trace . ("runQ: " <>) . showT <*> mapM_ run1Q . sortBy (flip compare)
+ where
+ run1Q :: QueuedUpdate -> BufferM ()
+ run1Q (QueuedUpdate { qUpdatePoint = p, qInsert = i, qDelete = d })
+ = do deleteNAt Forward d p
+ unless (R.null i) $ insertNAt i p
+
+openParen, closeParen :: Token
+openParen = Special '('
+closeParen = Special ')'
+
+isNormalParen :: Tree TT -> Bool
+isNormalParen (Paren t1 xs t2) =
+ tokT t1 == openParen && tokT t2 == closeParen && not (any isTuple xs)
+isNormalParen _ = False
+
+isTuple ::Tree TT -> Bool
+isTuple (Atom t) = tokT t == Special ','
+isTuple _ = False
+
+-- Assumes length of token is one character
+queueDelete :: TT -> QueuedUpdate
+queueDelete = queueReplaceWith ""
+
+-- Assumes length of token is one character
+queueReplaceWith :: R.YiString -> TT -> QueuedUpdate
+queueReplaceWith s t = QueuedUpdate { qUpdatePoint = posnOfs $ tokPosn t
+ , qInsert = s
+ , qDelete = 1
+ }
+
+-- Only strips comments from the top level
+stripComments :: Expr TT -> Expr TT
+stripComments = filter $ \t -> case t of { (Atom x) -> not (isComment $ tokT x); _ -> True }
+
+dollarifyTop :: Tree TT -> [QueuedUpdate]
+dollarifyTop p@(Paren t1 e t2)
+ | isNormalParen p = case stripComments e of
+ [Paren{}] -> [queueDelete t2, queueDelete t1]
+ e' -> dollarifyExpr e'
+dollarifyTop (Block blk) = dollarifyExpr . stripComments =<< [x | Expr x <- blk]
+dollarifyTop _ = []
+
+-- Expression must not contain comments
+dollarifyExpr :: Expr TT -> [QueuedUpdate]
+dollarifyExpr e@(_:_)
+ | p@(Paren t e2 t2) <- last e
+ , isNormalParen p
+ , all isSimple e
+ = let dollarifyLoop :: Expr TT -> [QueuedUpdate]
+ dollarifyLoop [] = []
+ dollarifyLoop e3@[Paren{}] = dollarifyExpr e3
+ dollarifyLoop e3 = if isCollapsible e3 then [queueDelete t2, queueReplaceWith "$ " t] else []
+ in dollarifyLoop $ stripComments e2
+dollarifyExpr _ = []
+
+isSimple :: Tree TT -> Bool
+isSimple (Paren{}) = True
+isSimple (Block{}) = False
+isSimple (Atom t) = tokT t `elem` [Number, CharTok, StringTok, VarIdent, ConsIdent]
+isSimple _ = False
+
+-- Expression must not contain comments
+isCollapsible :: Expr TT -> Bool
+isCollapsible = ((&&) `on` isSimple) . head <*> last
+
+selectedTree :: Expr TT -> Region -> Maybe (Tree TT)
+selectedTree e r = findLargestWithin r <$> getLastPath e (regionLast r)
+
+-- List must be non-empty
+findLargestWithin :: Region -> [Tree TT] -> Tree TT
+findLargestWithin r = fromMaybe . head <*> safeLast . takeWhile (within r)
+
+within :: Region -> Tree TT -> Bool
+within r t = includedRegion ((mkRegion . getFirstOffset <*> getLastOffset) t) r
+
+safeLast :: [a] -> Maybe a
+safeLast [] = Nothing
+safeLast s = return $ last s
+
+-- Here follows code for the precise haskell mode
+
+dollarifyP :: H.Tree TT -> BufferM ()
+dollarifyP e = maybe (return ()) dollarifyWithinP . selectedTreeP [e] =<< getSelectRegionB
+
+dollarifyWithinP :: H.Exp TT -> BufferM ()
+dollarifyWithinP = trace . ("dollarifyWithin: " <>) . showT <*> runQ . (dollarifyTopP =<<) . getAllSubTrees
+
+isNormalParenP :: H.Exp TT -> Bool
+isNormalParenP (H.Paren (H.PAtom r _) xs (H.PAtom r' _)) =
+ tokT r == openParen && tokT r' == closeParen && not (any isTupleP xs)
+isNormalParenP _ = False
+
+isTupleP :: H.Exp TT -> Bool
+isTupleP (H.PAtom t _) = tokT t == Special ','
+isTupleP _ = False
+
+-- Only strips comments from the top level
+stripCommentsP :: [H.Exp TT] -> [H.Exp TT]
+stripCommentsP = filter $ \t -> case t of { (H.PAtom x _) -> not (isComment $ tokT x); _ -> True }
+
+dollarifyTopP :: H.Exp TT -> [QueuedUpdate]
+dollarifyTopP p@(H.Paren (H.PAtom t1 _) e (H.PAtom t2 _))
+ | isNormalParenP p = case stripCommentsP e of
+ [H.Paren{}] -> [queueDelete t2, queueDelete t1]
+ e' -> dollarifyExprP e'
+dollarifyTopP (H.Block bList) = dollarifyExprP . stripCommentsP $ bList
+dollarifyTopP _ = []
+
+-- Expression must not contain comments
+dollarifyExprP :: [H.Exp TT] -> [QueuedUpdate]
+dollarifyExprP e@(_:_)
+ | p@(H.Paren (H.PAtom t _) e2 (H.PAtom t2 _)) <- last e
+ , isNormalParenP p
+ , all isSimpleP e
+ = let dollarifyLoop :: [H.Exp TT] -> [QueuedUpdate]
+ dollarifyLoop [] = []
+ dollarifyLoop e3@[H.Paren{}] = dollarifyExprP e3
+ dollarifyLoop e3 = if isCollapsibleP e3 then [queueDelete t2, queueReplaceWith "$ " t] else []
+ in dollarifyLoop $ stripCommentsP e2
+dollarifyExprP _ = []
+
+isSimpleP :: H.Exp TT -> Bool
+isSimpleP (H.Paren{}) = True
+isSimpleP (H.Block{}) = False
+isSimpleP (H.PAtom t _) = tokT t `elem` [Number, CharTok, StringTok, VarIdent, ConsIdent]
+isSimpleP _ = False
+
+-- Expression must not contain comments
+isCollapsibleP :: [H.Exp TT] -> Bool
+isCollapsibleP = ((&&) `on` isSimpleP) . head <*> last
+
+selectedTreeP :: [H.Exp TT] -> Region -> Maybe (H.Exp TT)
+selectedTreeP e r = findLargestWithinP r <$> getLastPath e (regionLast r)
+
+-- List must be non-empty
+findLargestWithinP :: Region -> [H.Exp TT] -> H.Exp TT
+findLargestWithinP r = fromMaybe . head <*> safeLast . takeWhile (withinP r)
+
+withinP :: Region -> H.Exp TT -> Bool
+withinP r t = includedRegion ((mkRegion . getFirstOffset <*> getLastOffset) t) r
+
+safeLastP :: [a] -> Maybe a
+safeLastP [] = Nothing
+safeLastP s = return $ last s
diff --git a/src/Yi/Syntax/Haskell.hs b/src/Yi/Syntax/Haskell.hs
new file mode 100644
index 0000000..d70d6bf
--- /dev/null
+++ b/src/Yi/Syntax/Haskell.hs
@@ -0,0 +1,745 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- we have lots of parsers which don't want signatures; and we have
+-- uniplate patterns
+{-# OPTIONS_GHC -fno-warn-missing-signatures
+ -fno-warn-incomplete-patterns
+ -fno-warn-name-shadowing #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- |
+-- Module : Yi.Syntax.Haskell
+-- License : GPL-2
+-- Maintainer : yi-devel@googlegroups.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- NOTES:
+-- Note if the layout of the first line (not comments)
+-- is wrong the parser will only parse what is in the blocks given by Layout.hs
+
+module Yi.Syntax.Haskell ( PModule
+ , PModuleDecl
+ , PImport
+ , Exp (..)
+ , Tree
+ , parse
+ , indentScanner
+ ) where
+
+import Control.Applicative (Alternative ((<|>), empty, many, some), optional)
+import Control.Arrow ((&&&))
+import Data.List ((\\))
+import Data.Maybe (fromJust, isNothing)
+import Yi.IncrementalParse
+import Yi.Lexer.Alex (Posn (Posn, posnOfs), Tok (Tok, tokT),
+ startPosn, tokBegin)
+import Yi.Lexer.Haskell
+import Yi.Syntax (Scanner)
+import Yi.Syntax.Layout (State, layoutHandler)
+import Yi.Syntax.Tree (IsTree (emptyNode, uniplate), sepBy1)
+
+indentScanner :: Scanner (AlexState lexState) TT
+ -> Scanner (Yi.Syntax.Layout.State Token lexState) TT
+indentScanner = layoutHandler startsLayout [(Special '(', Special ')'),
+ (Reserved Let, Reserved In),
+ (Special '[', Special ']'),
+ (Special '{', Special '}')]
+ ignoredToken
+ (Special '<', Special '>', Special '.')
+ isBrace
+
+-- HACK: We insert the Special '<', '>', '.', which do not occur in
+-- normal haskell parsing.
+
+-- | Check if a token is a brace, this function is used to
+-- fix the layout so that do { works correctly
+isBrace :: TT -> Bool
+isBrace (Tok br _ _) = Special '{' == br
+
+-- | Theese are the tokens ignored by the layout handler.
+ignoredToken :: TT -> Bool
+ignoredToken (Tok t _ (Posn{})) = isComment t || t == CppDirective
+
+type Tree = PModule
+type PAtom = Exp
+type Block = Exp
+type PGuard = Exp
+type PModule = Exp
+type PModuleDecl = Exp
+type PImport = Exp
+
+
+-- | Exp can be expression or declaration
+data Exp t
+ = PModule { comments :: [t]
+ , progMod :: Maybe (PModule t)
+ }
+ | ProgMod { modDecl :: PModuleDecl t
+ , body :: PModule t -- ^ The module declaration part
+ }
+ | Body { imports :: Exp t -- [PImport t]
+ , content :: Block t
+ , extraContent :: Block t -- ^ The body of the module
+ }
+ | PModuleDecl { moduleKeyword :: PAtom t
+ , name :: PAtom t
+ , exports :: Exp t
+ , whereKeyword :: Exp t
+ }
+ | PImport { importKeyword :: PAtom t
+ , qual :: Exp t
+ , name' :: PAtom t
+ , as :: Exp t
+ , specification :: Exp t
+ }
+
+ | TS t [Exp t] -- ^ Type signature
+ | PType { typeKeyword :: PAtom t
+ , typeCons :: Exp t
+ , equal :: PAtom t
+ , btype :: Exp t
+ } -- ^ Type declaration
+ | PData { dataKeyword :: PAtom t
+ , dtypeCons :: Exp t
+ , dEqual :: Exp t
+ , dataRhs :: Exp t
+ } -- ^ Data declaration
+ | PData' { dEqual :: PAtom t
+ , dataCons :: Exp t -- ^ Data declaration RHS
+ }
+ | PClass { cKeyword :: PAtom t -- Can be class or instance
+ , cHead :: Exp t
+ , cwhere :: Exp t -- ^ Class declaration
+ }
+ -- declaration
+ -- declarations and parts of them follow
+ | Paren (PAtom t) [Exp t] (PAtom t) -- ^ A parenthesized, bracked or braced
+ | Block [Exp t] -- ^ A block of things separated by layout
+ | PAtom t [t] -- ^ An atom is a token followed by many comments
+ | Expr [Exp t] -- ^
+ | PWhere (PAtom t) (Exp t) (Exp t) -- ^ Where clause
+ | Bin (Exp t) (Exp t)
+ -- an error with comments following so we never color comments in wrong
+ -- color. The error has an extra token, the Special '!' token to
+ -- indicate that it contains an error
+ | PError { errorTok :: t
+ , marker :: t
+ , commentList :: [t] -- ^ An wrapper for errors
+ }
+ -- rhs that begins with Equal
+ | RHS (PAtom t) (Exp t) -- ^ Righthandside of functions with =
+ | Opt (Maybe (Exp t)) -- ^ An optional
+ | Modid t [t] -- ^ Module identifier
+ | Context (Exp t) (Exp t) (PAtom t) -- ^
+ | PGuard [PGuard t] -- ^ Righthandside of functions with |
+ -- the PAtom in PGuard' does not contain any comments
+ | PGuard' (PAtom t) (Exp t) (PAtom t)
+ -- type constructor is just a wrapper to indicate which highlightning to
+ -- use.
+ | TC (Exp t) -- ^ Type constructor
+ -- data constructor same as with the TC constructor
+ | DC (Exp t) -- ^ Data constructor
+ | PLet (PAtom t) (Exp t) (Exp t) -- ^ let expression
+ | PIn t [Exp t]
+ deriving (Show, Foldable)
+
+instance IsTree Exp where
+ emptyNode = Expr []
+ uniplate tree = case tree of
+ (ProgMod a b) -> ([a,b], \[a,b] -> ProgMod a b)
+ (Body x exp exp') -> ([x, exp, exp'], \[x, exp, exp'] -> Body x exp exp')
+ (PModule x (Just e)) -> ([e],\[e] -> PModule x (Just e))
+ (Paren l g r) -> -- TODO: improve
+ (l:g ++ [r], \(l:gr) -> Paren l (init gr) (last gr))
+ (RHS l g) -> ([l,g],\[l,g] -> (RHS l g))
+ (Block s) -> (s,Block)
+ (PLet l s i) -> ([l,s,i],\[l,s,i] -> PLet l s i)
+ (PIn x ts) -> (ts,PIn x)
+ (Expr a) -> (a,Expr)
+ (PClass a b c) -> ([a,b,c],\[a,b,c] -> PClass a b c)
+ (PWhere a b c) -> ([a,b,c],\[a,b,c] -> PWhere a b c)
+ (Opt (Just x)) -> ([x],\[x] -> (Opt (Just x)))
+ (Bin a b) -> ([a,b],\[a,b] -> (Bin a b))
+ (PType a b c d) -> ([a,b,c,d],\[a,b,c,d] -> PType a b c d)
+ (PData a b c d) -> ([a,b,c,d],\[a,b,c,d] -> PData a b c d)
+ (PData' a b) -> ([a,b] ,\[a,b] -> PData' a b)
+ (Context a b c) -> ([a,b,c],\[a,b,c] -> Context a b c)
+ (PGuard xs) -> (xs,PGuard)
+ (PGuard' a b c) -> ([a,b,c],\[a,b,c] -> PGuard' a b c)
+ (TC e) -> ([e],\[e] -> TC e)
+ (DC e) -> ([e],\[e] -> DC e)
+ PModuleDecl a b c d -> ([a,b,c,d],\[a,b,c,d] -> PModuleDecl a b c d)
+ PImport a b c d e -> ([a,b,c,d,e],\[a,b,c,d,e] -> PImport a b c d e)
+ t -> ([],const t)
+
+-- | The parser
+parse :: P TT (Tree TT)
+parse = pModule <* eof
+
+-- | @pModule@ parse a module
+pModule :: Parser TT (PModule TT)
+pModule = PModule <$> pComments <*> optional
+ (pBlockOf' (ProgMod <$> pModuleDecl
+ <*> pModBody <|> pBody))
+
+-- | Parse a body that follows a module
+pModBody :: Parser TT (PModule TT)
+pModBody = (exact [startBlock] *>
+ (Body <$> pImports
+ <*> ((pTestTok elems *> pBod)
+ <|> pEmptyBL) <* exact [endBlock]
+ <*> pBod
+ <|> Body <$> noImports
+ <*> ((pBod <|> pEmptyBL) <* exact [endBlock])
+ <*> pBod))
+ <|> (exact [nextLine] *> pBody)
+ <|> Body <$> pure emptyNode <*> pEmptyBL <*> pEmptyBL
+ where pBod = Block <$> pBlocks pTopDecl
+ elems = [Special ';', nextLine, startBlock]
+
+-- | @pEmptyBL@ A parser returning an empty block
+pEmptyBL :: Parser TT (Exp TT)
+pEmptyBL = Block <$> pEmpty
+
+-- | Parse a body of a program
+pBody :: Parser TT (PModule TT)
+pBody = Body <$> noImports <*> (Block <$> pBlocks pTopDecl) <*> pEmptyBL
+ <|> Body <$> pImports <*> ((pTestTok elems *> (Block <$> pBlocks pTopDecl))
+ <|> pEmptyBL) <*> pEmptyBL
+ where elems = [nextLine, startBlock]
+
+noImports :: Parser TT (Exp TT)
+noImports = notNext [Reserved Import] *> pure emptyNode
+ where notNext f = testNext $ uncurry (||) . (&&&) isNothing
+ (flip notElem f . tokT . fromJust)
+
+-- Helper functions for parsing follows
+-- | Parse Variables
+pVarId :: Parser TT (Exp TT)
+pVarId = pAtom [VarIdent, Reserved Other, Reserved As]
+
+-- | Parse VarIdent and ConsIdent
+pQvarid :: Parser TT (Exp TT)
+pQvarid = pAtom [VarIdent, ConsIdent, Reserved Other, Reserved As]
+
+-- | Parse an operator using please
+pQvarsym :: Parser TT (Exp TT)
+pQvarsym = pParen ((:) <$> please (PAtom <$> sym isOperator <*> pComments)
+ <*> pEmpty)
+
+-- | Parse any operator
+isOperator :: Token -> Bool
+isOperator (Operator _) = True
+isOperator (ReservedOp _) = True
+isOperator (ConsOperator _) = True
+isOperator _ = False
+
+-- | Parse a consident
+pQtycon :: Parser TT (Exp TT)
+pQtycon = pAtom [ConsIdent]
+
+-- | Parse many variables
+pVars :: Parser TT (Exp TT)
+pVars = pMany pVarId
+
+-- | Parse a nextline token (the nexLine token is inserted by Layout.hs)
+nextLine :: Token
+nextLine = Special '.'
+
+-- | Parse a startBlock token
+startBlock :: Token
+startBlock = Special '<'
+
+-- | Parse a endBlock token
+endBlock :: Token
+endBlock = Special '>'
+
+pEmpty :: Applicative f => f [a]
+pEmpty = pure []
+
+pToList :: Applicative f => f a -> f [a]
+pToList = (box <$>)
+ where box x = [x]
+
+-- | @sym f@ returns a parser parsing @f@ as a special symbol
+sym :: (Token -> Bool) -> Parser TT TT
+sym f = symbol (f . tokT)
+
+-- | @exact tokList@ parse anything that is in @tokList@
+exact :: [Token] -> Parser TT TT
+exact = sym . flip elem
+
+
+-- | @please p@ returns a parser parsing either @p@ or recovers with the
+-- (Special '!') token.
+please :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+please = (<|>) (PError <$> recoverWith errTok
+ <*> errTok
+ <*> pEmpty)
+
+-- | Parse anything, as errors
+pErr :: Parser TT (Exp TT)
+pErr = PError <$> recoverWith (sym $ not . uncurry (||) . (&&&) isComment
+ (== CppDirective))
+ <*> errTok
+ <*> pComments
+
+-- | Parse an ConsIdent
+ppCons :: Parser TT (Exp TT)
+ppCons = ppAtom [ConsIdent]
+
+-- | Parse a keyword
+pKW :: [Token] -> Parser TT (Exp TT) -> Parser TT (Exp TT)
+pKW k r = Bin <$> pAtom k <*> r
+
+-- | Parse an unary operator with and without using please
+pOP :: [Token] -> Parser TT (Exp TT) -> Parser TT (Exp TT)
+pOP op r = Bin <$> pAtom op <*> r
+
+--ppOP op r = Bin <$> ppAtom op <*> r
+
+-- | Parse comments
+pComments :: Parser TT [TT]
+pComments = many $ sym $ uncurry (||) . (&&&) isComment (== CppDirective)
+
+-- | Parse something thats optional
+pOpt :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+pOpt x = Opt <$> optional x
+
+-- | Parse an atom with, and without using please
+pAtom, ppAtom :: [Token] -> Parser TT (Exp TT)
+pAtom = flip pCAtom pComments
+
+ppAtom at = pAtom at <|> recoverAtom
+
+recoverAtom :: Parser TT (Exp TT)
+recoverAtom = PAtom <$> recoverWith errTok <*> pEmpty
+
+-- | Parse an atom with optional comments
+pCAtom :: [Token] -> Parser TT [TT] -> Parser TT (Exp TT)
+pCAtom r c = PAtom <$> exact r <*> c
+
+pBareAtom a = pCAtom a pEmpty
+
+-- | @pSepBy p sep@ parse /zero/ or more occurences of @p@, separated
+-- by @sep@, with optional ending @sep@,
+-- this is quite similar to the sepBy function provided in
+-- Parsec, but this one allows an optional extra separator at the end.
+--
+-- > commaSep p = p `pSepBy` (symbol (==(Special ',')))
+
+pSepBy :: Parser TT (Exp TT) -> Parser TT (Exp TT) -> Parser TT [Exp TT]
+pSepBy p sep = pEmpty
+ <|> (:) <$> p <*> (pSepBy1 p sep <|> pEmpty)
+ <|> pToList sep -- optional ending separator
+ where pSepBy1 r p' = (:) <$> p' <*> (pEmpty <|> pSepBy1 p' r)
+
+-- | Separate a list of things separated with comma inside of parenthesis
+pParenSep :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+pParenSep = pParen . flip pSepBy pComma
+
+-- | Parse a comma separator
+pComma :: Parser TT (Exp TT)
+pComma = pAtom [Special ',']
+
+-- End of helper functions Parsing different parts follows
+
+-- | Parse a Module declaration
+pModuleDecl :: Parser TT (PModuleDecl TT)
+pModuleDecl = PModuleDecl <$> pAtom [Reserved Module]
+ <*> ppAtom [ConsIdent]
+ <*> pOpt (pParenSep pExport)
+ <*> (optional (exact [nextLine]) *>
+ (Bin <$> ppAtom [Reserved Where])
+ <*> pMany pErr) <* pTestTok elems
+ where elems = [nextLine, startBlock, endBlock]
+
+pExport :: Parser TT (Exp TT)
+pExport = optional (exact [nextLine]) *> please
+ ( pVarId
+ <|> pEModule
+ <|> Bin <$> pQvarsym <*> (DC <$> pOpt expSpec) -- typeOperator
+ <|> Bin <$> (TC <$> pQtycon) <*> (DC <$> pOpt expSpec)
+ )
+ where expSpec = pParen (pToList (please (pAtom [ReservedOp DoubleDot]))
+ <|> pSepBy pQvarid pComma)
+
+-- | Check if next token is in given list
+pTestTok :: [Token] -> Parser TT ()
+pTestTok f = testNext (uncurry (||) . (&&&) isNothing
+ (flip elem f . tokT . fromJust))
+
+-- | Parse several imports
+pImports :: Parser TT (Exp TT) -- [PImport TT]
+pImports = Expr <$> many (pImport
+ <* pTestTok pEol
+ <* optional (some $ exact [nextLine, Special ';']))
+ where pEol = [Special ';', nextLine, endBlock]
+
+-- | Parse one import
+pImport :: Parser TT (PImport TT)
+pImport = PImport <$> pAtom [Reserved Import]
+ <*> pOpt (pAtom [Reserved Qualified])
+ <*> ppAtom [ConsIdent]
+ <*> pOpt (pKW [Reserved As] ppCons)
+ <*> (TC <$> pImpSpec)
+ where pImpSpec = Bin <$> pKW [Reserved Hiding]
+ (please pImpS) <*> pMany pErr
+ <|> Bin <$> pImpS <*> pMany pErr
+ <|> pMany pErr
+ pImpS = DC <$> pParenSep pExp'
+ pExp' = Bin
+ <$> (PAtom <$> sym
+ (uncurry (||) . (&&&)
+ (`elem` [VarIdent, ConsIdent])
+ isOperator) <*> pComments
+ <|> pQvarsym)
+ <*> pOpt pImpS
+
+-- | Parse simple type synonyms
+pType :: Parser TT (Exp TT)
+pType = PType <$> (Bin <$> pAtom [Reserved Type]
+ <*> pOpt (pAtom [Reserved Instance]))
+ <*> (TC . Expr <$> pTypeExpr')
+ <*> ppAtom [ReservedOp Equal]
+ <*> (TC . Expr <$> pTypeExpr')
+
+-- | Parse data declarations
+pData :: Parser TT (Exp TT)
+pData = PData <$> pAtom [Reserved Data, Reserved NewType]
+ <*> (TC . Expr <$> pTypeExpr')
+ <*> pOpt (pDataRHS <|> pGadt)
+ <*> pOpt pDeriving
+
+
+pGadt :: Parser TT (Exp TT)
+pGadt = pWhere pTypeDecl
+
+-- | Parse second half of the data declaration, if there is one
+pDataRHS :: Parser TT (Exp TT)
+pDataRHS = PData' <$> pAtom [ReservedOp Equal] <*> pConstrs
+
+
+-- | Parse a deriving
+pDeriving :: Parser TT (Exp TT)
+pDeriving = pKW [Reserved Deriving] (TC . Expr <$> pTypeExpr')
+
+pAtype :: Parser TT (Exp TT)
+pAtype = pAtype'
+ <|> pErr
+
+pAtype' :: Parser TT (Exp TT)
+pAtype' = pTypeCons
+ <|> pParen (many $ pExprElem [])
+ <|> pBrack (many $ pExprElem [])
+
+pTypeCons :: Parser TT (Exp TT)
+pTypeCons = Bin <$> pAtom [ConsIdent]
+ <*> please (pMany $ pAtom [VarIdent, ConsIdent])
+
+pContext :: Parser TT (Exp TT)
+pContext = Context <$> pOpt pForAll
+ <*> (TC <$> (pClass' <|> pParenSep pClass'))
+ <*> ppAtom [ReservedOp DoubleRightArrow]
+ where pClass' :: Parser TT (Exp TT)
+ pClass' = Bin <$> pQtycon
+ <*> (please pVarId
+ <|> pParen ((:) <$> please pVarId
+ <*> many pAtype'))
+
+-- | Parse for all
+pForAll :: Parser TT (Exp TT)
+pForAll = pKW [Reserved Forall]
+ (Bin <$> pVars <*> ppAtom [Operator "."])
+
+pConstrs :: Parser TT (Exp TT)
+pConstrs = Bin <$> (Bin <$> pOpt pContext <*> pConstr)
+ <*> pMany (pOP [ReservedOp Pipe]
+ (Bin <$> pOpt pContext <*> please pConstr))
+
+pConstr :: Parser TT (Exp TT)
+pConstr = Bin <$> pOpt pForAll
+ <*> (Bin <$>
+ (Bin <$> (DC <$> pAtype) <*>
+ (TC <$> pMany (strictF pAtype))) <*> pOpt st)
+ <|> Bin <$> lrHs <*> pMany (strictF pAtype)
+ <|> pErr
+ where lrHs = pOP [Operator "!"] pAtype
+ st = pEBrace (pTypeDecl `sepBy1` pBareAtom [Special ','])
+ -- named fields declarations
+
+-- | Parse optional strict variables
+strictF :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+strictF a = Bin <$> pOpt (pAtom [Operator "!"]) <*> a
+
+
+-- | Exporting module
+pEModule ::Parser TT (Exp TT)
+pEModule = pKW [Reserved Module]
+ $ please (Modid <$> exact [ConsIdent] <*> pComments)
+
+-- | Parse a Let expression
+pLet :: Parser TT (Exp TT)
+pLet = PLet <$> pAtom [Reserved Let]
+ <*> pBlock pFunDecl
+ <*> pOpt (pBareAtom [Reserved In])
+
+-- | Parse a Do block
+pDo :: Parser TT (Exp TT)
+pDo = Bin <$> pAtom [Reserved Do]
+ <*> pBlock (pExpr ((Special ';' : recognizedSometimes)
+ \\ [ReservedOp LeftArrow]))
+
+-- | Parse part of a lambda binding.
+pLambda :: Parser TT (Exp TT)
+pLambda = Bin <$> pAtom [ReservedOp BackSlash]
+ <*> (Bin <$> (Expr <$> pPattern)
+ <*> please (pBareAtom [ReservedOp RightArrow]))
+
+-- | Parse an Of block
+pOf :: Parser TT (Exp TT)
+pOf = Bin <$> pAtom [Reserved Of]
+ <*> pBlock pAlternative
+
+pAlternative = Bin <$> (Expr <$> pPattern)
+ <*> please (pFunRHS (ReservedOp RightArrow))
+
+-- | Parse classes and instances
+-- This is very imprecise, but shall suffice for now.
+-- At least is does not complain too often.
+pClass :: Parser TT (Exp TT)
+pClass = PClass <$> pAtom [Reserved Class, Reserved Instance]
+ <*> (TC . Expr <$> pTypeExpr')
+ <*> pOpt (please (pWhere pTopDecl))
+ -- use topDecl since we have associated types and such.
+
+
+-- | Parse some guards and a where clause
+pGuard :: Token -> Parser TT (Exp TT)
+pGuard equalSign = PGuard
+ <$> some (PGuard' <$> pCAtom [ReservedOp Pipe] pEmpty <*>
+ -- comments are by default parsed after this
+ pExpr (recognizedSometimes
+ -- these two symbols can appear in guards.
+ \\ [ReservedOp LeftArrow, Special ','])
+ <*> please (pEq equalSign))
+ -- this must be -> if used in case
+
+-- | Right-hand-side of a function or case equation (after the pattern)
+pFunRHS :: Token -> Parser TT (Exp TT)
+pFunRHS equalSign =
+ Bin <$> (pGuard equalSign <|> pEq equalSign) <*> pOpt (pWhere pFunDecl)
+
+pWhere :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+pWhere p =
+ PWhere <$> pAtom [Reserved Where] <*> please (pBlock p) <*> pMany pErr
+-- After a where there might "misaligned" code that do not "belong" to anything.
+-- Here we swallow it as errors.
+
+-- Note that this can both parse an equation and a type declaration.
+-- Since they can start with the same token, the left part is factored here.
+pDecl :: Bool -> Bool -> Parser TT (Exp TT)
+pDecl acceptType acceptEqu =
+ Expr <$> ((Yuck $
+ Enter "missing end of type or equation declaration" $ pure [])
+ <|> ((:) <$> pElem False recognizedSometimes
+ <*> pToList (pDecl acceptType acceptEqu))
+ <|> ((:) <$> pBareAtom [Special ',']
+ <*> pToList (pDecl acceptType False))
+ -- if a comma is found, then the rest must be a type
+ -- declaration.
+ <|> (if acceptType then pTypeEnding else empty)
+ <|> (if acceptEqu then pEquEnding else empty))
+ where pTypeEnding = (:) <$> (TS <$> exact [ReservedOp DoubleColon]
+ <*> pTypeExpr') <*> pure []
+ pEquEnding = (:) <$> pFunRHS (ReservedOp Equal) <*> pure []
+
+pFunDecl = pDecl True True
+pTypeDecl = pDecl True False
+--pEquation = pDecl False True
+
+
+-- | The RHS of an equation.
+pEq :: Token -> Parser TT (Exp TT)
+pEq equalSign = RHS <$> pBareAtom [equalSign] <*> pExpr'
+
+-- | Parse many of something
+pMany :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+pMany p = Expr <$> many p
+
+-- | Parse a some of something separated by the token (Special '.')
+pBlocks :: Parser TT r -> Parser TT [r]
+pBlocks p = p `sepBy1` exact [nextLine]
+
+-- | Parse a some of something separated by the token (Special '.'), or nothing
+--pBlocks' :: Parser TT r -> Parser TT (BL.BList r)
+pBlocks' p = pBlocks p <|> pure []
+
+-- | Parse a block of some something separated by the tok (Special '.')
+pBlockOf :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+pBlockOf p = Block <$> pBlockOf' (pBlocks p) -- see HACK above
+
+
+pBlock :: Parser TT (Exp TT) -> Parser TT (Exp TT)
+pBlock p = pBlockOf' (Block <$> pBlocks' p)
+ <|> pEBrace (p `sepBy1` exact [Special ';'] <|> pure [])
+ <|> (Yuck $ Enter "block expected" pEmptyBL)
+
+-- | Parse something surrounded by (Special '<') and (Special '>')
+pBlockOf' :: Parser TT a -> Parser TT a
+pBlockOf' p = exact [startBlock] *> p <* exact [endBlock] -- see HACK above
+-- note that, by construction, '<' and '>' will always be matched, so
+-- we don't try to recover errors with them.
+
+-- | Parse something that can contain a data, type declaration or a class
+pTopDecl :: Parser TT (Exp TT)
+pTopDecl = pFunDecl
+ <|> pType
+ <|> pData
+ <|> pClass
+ <|> pure emptyNode
+
+
+-- | A "normal" expression, where none of the following symbols are acceptable.
+pExpr' = pExpr recognizedSometimes
+
+recognizedSometimes = [ReservedOp DoubleDot,
+ Special ',',
+ ReservedOp Pipe,
+ ReservedOp Equal,
+ ReservedOp LeftArrow,
+ ReservedOp RightArrow,
+ ReservedOp DoubleRightArrow,
+ ReservedOp BackSlash,
+ ReservedOp DoubleColon
+ ]
+
+-- | Parse an expression, as a concatenation of elements.
+pExpr :: [Token] -> Parser TT (Exp TT)
+pExpr at = Expr <$> pExprOrPattern True at
+
+-- | Parse an expression, as a concatenation of elements.
+pExprOrPattern :: Bool -> [Token] -> Parser TT [Exp TT]
+pExprOrPattern isExpresssion at =
+ pure []
+ <|> ((:) <$> pElem isExpresssion at <*> pExprOrPattern True at)
+ <|> ((:) <$> (TS <$> exact [ReservedOp DoubleColon] <*> pTypeExpr')
+ <*> pure [])
+ -- TODO: not really correct: in (x :: X , y :: Z), all after the
+ -- first :: will be a "type".
+
+pPattern = pExprOrPattern False recognizedSometimes
+
+pExprElem = pElem True
+
+-- | Parse an "element" of an expression or a pattern.
+-- "at" is a list of symbols that, if found, should be considered errors.
+pElem :: Bool -> [Token] -> Parser TT (Exp TT)
+pElem isExpresssion at =
+ pCParen (pExprOrPattern isExpresssion
+ -- might be a tuple, so accept commas as noise
+ (recognizedSometimes \\ [Special ','])) pEmpty
+ <|> pCBrack (pExprOrPattern isExpresssion
+ (recognizedSometimes \\ [ ReservedOp DoubleDot, ReservedOp Pipe
+ , ReservedOp LeftArrow
+ , Special ','])) pEmpty -- list thing
+ <|> pCBrace (many $ pElem isExpresssion
+ -- record: TODO: improve
+ (recognizedSometimes \\ [ ReservedOp Equal, Special ','
+ , ReservedOp Pipe])) pEmpty
+ <|> (Yuck $ Enter "incorrectly placed block" $
+ -- no error token, but the previous keyword will be one. (of, where, ...)
+ pBlockOf (pExpr recognizedSometimes))
+ <|> (PError <$> recoverWith
+ (sym $ flip elem $ isNoiseErr at) <*> errTok <*> pEmpty)
+ <|> (PAtom <$> sym (`notElem` isNotNoise at) <*> pEmpty)
+ <|> if isExpresssion then pLet <|> pDo <|> pOf <|> pLambda else empty
+ -- TODO: support type expressions
+
+pTypeExpr at = many (pTypeElem at)
+pTypeExpr' = pTypeExpr (recognizedSometimes \\ [ReservedOp RightArrow,
+ ReservedOp DoubleRightArrow])
+
+pTypeElem :: [Token] -> Parser TT (Exp TT)
+pTypeElem at
+ = pCParen (pTypeExpr (recognizedSometimes
+ \\ [ ReservedOp RightArrow,
+ ReservedOp DoubleRightArrow,
+ -- might be a tuple, so accept commas as noise
+ Special ','])) pEmpty
+ <|> pCBrack pTypeExpr' pEmpty
+ <|> pCBrace pTypeExpr' pEmpty -- TODO: this is an error: mark as such.
+ <|> (Yuck $ Enter "incorrectly placed block" $
+ pBlockOf (pExpr recognizedSometimes))
+ <|> (PError <$> recoverWith
+ (sym $ flip elem $ isNoiseErr at) <*> errTok <*> pEmpty)
+ <|> (PAtom <$> sym (`notElem` isNotNoise at) <*> pEmpty)
+
+-- | List of things that always should be parsed as errors
+isNoiseErr :: [Token] -> [Token]
+isNoiseErr r = recoverableSymbols ++ r
+
+recoverableSymbols = recognizedSymbols \\ fmap Special "([{<>."
+-- We just don't recover opening symbols (only closing are "fixed").
+-- Layout symbols "<>." are never recovered, because layout is
+-- constructed correctly.
+
+-- | List of things that should not be parsed as noise
+isNotNoise :: [Token] -> [Token]
+isNotNoise r = recognizedSymbols ++ r
+
+-- | These symbols are always properly recognized, and therefore they
+-- should never be accepted as "noise" inside expressions.
+recognizedSymbols =
+ [ Reserved Let
+ , Reserved In
+ , Reserved Do
+ , Reserved Of
+ , Reserved Class
+ , Reserved Instance
+ , Reserved Deriving
+ , Reserved Module
+ , Reserved Import
+ , Reserved Type
+ , Reserved Data
+ , Reserved NewType
+ , Reserved Where] ++ fmap Special "()[]{}<>."
+
+-- | Parse parenthesis, brackets and braces containing
+-- an expression followed by possible comments
+pCParen, pCBrace, pCBrack
+ :: Parser TT [Exp TT] -> Parser TT [TT] -> Parser TT (Exp TT)
+
+pCParen p c = Paren <$> pCAtom [Special '('] c
+ <*> p <*> (recoverAtom <|> pCAtom [Special ')'] c)
+
+pCBrace p c = Paren <$> pCAtom [Special '{'] c
+ <*> p <*> (recoverAtom <|> pCAtom [Special '}'] c)
+
+pCBrack p c = Paren <$> pCAtom [Special '['] c
+ <*> p <*> (recoverAtom <|> pCAtom [Special ']'] c)
+
+pParen, pBrack :: Parser TT [Exp TT] -> Parser TT (Exp TT)
+
+pParen = flip pCParen pComments
+
+--pBrace = flip pCBrace pComments
+
+pBrack = flip pCBrack pComments
+
+-- pEBrace parse an opening brace, followed by zero comments
+-- then followed by an closing brace and some comments
+pEBrace p = Paren <$> pCAtom [Special '{'] pEmpty
+ <*> p <*> (recoverAtom <|> pCAtom [Special '}'] pComments)
+
+-- | Create a special error token. (e.g. fill in where there is no
+-- correct token to parse) Note that the position of the token has to
+-- be correct for correct computation of node spans.
+errTok = mkTok <$> curPos
+ where curPos = tB <$> lookNext
+ tB Nothing = maxBound
+ tB (Just x) = tokBegin x
+ mkTok p = Tok (Special '!') 0 (startPosn {posnOfs = p})
diff --git a/src/Yi/Syntax/Paren.hs b/src/Yi/Syntax/Paren.hs
new file mode 100644
index 0000000..5b3f97c
--- /dev/null
+++ b/src/Yi/Syntax/Paren.hs
@@ -0,0 +1,172 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- |
+-- Module : Yi.Syntax.Paren
+-- License : GPL-2
+-- Maintainer : yi-devel@googlegroups.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Parser for Haskell that only cares about parenthesis and layout.
+
+module Yi.Syntax.Paren where
+
+import Prelude hiding (elem)
+
+import Control.Applicative (Alternative ((<|>), many))
+import Data.Foldable (elem, toList)
+import Data.Maybe (listToMaybe)
+import Data.Monoid (Endo (Endo, appEndo), (<>))
+import Yi.IncrementalParse (P, Parser, eof, lookNext, recoverWith, symbol)
+import Yi.Lexer.Alex hiding (tokenToStyle)
+import Yi.Lexer.Haskell
+import Yi.Style (StyleName, errorStyle, hintStyle)
+import Yi.Syntax (Point, Scanner, Span)
+import Yi.Syntax.Layout (State, layoutHandler)
+import Yi.Syntax.Tree
+
+indentScanner :: Scanner (AlexState lexState) TT
+ -> Scanner (Yi.Syntax.Layout.State Token lexState) TT
+indentScanner = layoutHandler startsLayout [(Special '(', Special ')'),
+ (Special '[', Special ']'),
+ (Special '{', Special '}')] ignoredToken
+ (Special '<', Special '>', Special '.') isBrace
+
+-- HACK: We insert the Special '<', '>', '.', that don't occur in normal haskell
+-- parsing.
+
+isBrace :: TT -> Bool
+isBrace (Tok b _ _) = Special '{' == b
+
+ignoredToken :: TT -> Bool
+ignoredToken (Tok t _ _) = isComment t || t == CppDirective
+
+isNoise :: Token -> Bool
+isNoise (Special c) = c `elem` (";,`" :: String)
+isNoise _ = True
+
+type Expr t = [Tree t]
+
+data Tree t
+ = Paren t (Expr t) t -- A parenthesized expression (maybe with [ ] ...)
+ | Block ([Tree t]) -- A list of things separated by layout (as in do; etc.)
+ | Atom t
+ | Error t
+ | Expr [Tree t]
+ deriving (Show, Foldable, Functor)
+
+instance IsTree Tree where
+ emptyNode = Expr []
+ uniplate (Paren l g r) = (g,\g' -> Paren l g' r)
+ uniplate (Expr g) = (g,Expr)
+ uniplate (Block s) = (s,Block)
+ uniplate t = ([],const t)
+
+-- | Search the given list, and return the 1st tree after the given
+-- point on the given line. This is the tree that will be moved if
+-- something is inserted at the point. Precondition: point is in the
+-- given line.
+
+-- TODO: this should be optimized by just giving the point of the end
+-- of the line
+getIndentingSubtree :: Tree TT -> Point -> Int -> Maybe (Tree TT)
+getIndentingSubtree root offset line =
+ listToMaybe [t | (t,posn) <- takeWhile ((<= line) . posnLine . snd) allSubTreesPosn,
+ -- it's very important that we do a linear search
+ -- here (takeWhile), so that the tree is evaluated
+ -- lazily and therefore parsing it can be lazy.
+ posnOfs posn > offset, posnLine posn == line]
+ where allSubTreesPosn = [(t',posn) | t'@(Block _) <-filter (not . null . toList) (getAllSubTrees root),
+ let (tok:_) = toList t',
+ let posn = tokPosn tok]
+
+-- | Given a tree, return (first offset, number of lines).
+getSubtreeSpan :: Tree TT -> (Point, Int)
+getSubtreeSpan tree = (posnOfs first, lastLine - firstLine)
+ where bounds@[first, _last] = fmap (tokPosn . assertJust) [getFirstElement tree, getLastElement tree]
+ [firstLine, lastLine] = fmap posnLine bounds
+ assertJust (Just x) = x
+ assertJust _ = error "assertJust: Just expected"
+
+-- dropWhile' f = foldMap (\x -> if f x then mempty else Endo (x :))
+--
+-- isBefore l (Atom t) = isBefore' l t
+-- isBefore l (Error t) = isBefore l t
+-- isBefore l (Paren l g r) = isBefore l r
+-- isBefore l (Block s) = False
+--
+-- isBefore' l (Tok {tokPosn = Posn {posnLn = l'}}) =
+
+
+parse :: P TT (Tree TT)
+parse = Expr <$> parse' tokT tokFromT
+
+parse' :: (TT -> Token) -> (Token -> TT) -> P TT [Tree TT]
+parse' toTok _ = pExpr <* eof
+ where
+ -- parse a special symbol
+ sym c = symbol (isSpecial [c] . toTok)
+
+ pleaseSym c = recoverWith errTok <|> sym c
+
+ pExpr :: P TT (Expr TT)
+ pExpr = many pTree
+
+ pBlocks = (Expr <$> pExpr) `sepBy1` sym '.' -- the '.' is generated by the layout, see HACK above
+ -- note that we can have empty statements, hence we use sepBy1.
+
+ pTree :: P TT (Tree TT)
+ pTree = (Paren <$> sym '(' <*> pExpr <*> pleaseSym ')')
+ <|> (Paren <$> sym '[' <*> pExpr <*> pleaseSym ']')
+ <|> (Paren <$> sym '{' <*> pExpr <*> pleaseSym '}')
+
+ <|> (Block <$> (sym '<' *> pBlocks <* sym '>')) -- see HACK above
+
+ <|> (Atom <$> symbol (isNoise . toTok))
+ <|> (Error <$> recoverWith (symbol (isSpecial "})]" . toTok)))
+
+ -- note that, by construction, '<' and '>' will always be matched, so
+ -- we don't try to recover errors with them.
+
+getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
+getStrokes point _begin _end t0 = -- trace (show t0)
+ result
+ where getStrokes' (Atom t) = one (ts t)
+ getStrokes' (Error t) = one (modStroke errorStyle (ts t)) -- paint in red
+ getStrokes' (Block s) = getStrokesL s
+ getStrokes' (Expr g) = getStrokesL g
+ getStrokes' (Paren l g r)
+ | isErrorTok $ tokT r = one (modStroke errorStyle (ts l)) <> getStrokesL g
+ -- left paren wasn't matched: paint it in red.
+ -- note that testing this on the "Paren" node actually forces the parsing of the
+ -- right paren, undermining online behaviour.
+ | posnOfs (tokPosn l) == point || posnOfs (tokPosn r) == point - 1
+ = one (modStroke hintStyle (ts l)) <> getStrokesL g <> one (modStroke hintStyle (ts r))
+ | otherwise = one (ts l) <> getStrokesL g <> one (ts r)
+ getStrokesL = foldMap getStrokes'
+ ts = tokenToStroke
+ result = appEndo (getStrokes' t0) []
+ one x = Endo (x :)
+
+
+tokenToStroke :: TT -> Stroke
+tokenToStroke = fmap tokenToStyle . tokToSpan
+
+modStroke :: StyleName -> Stroke -> Stroke
+modStroke f = fmap (f `mappend`)
+
+tokenToAnnot :: TT -> Maybe (Span String)
+tokenToAnnot = sequenceA . tokToSpan . fmap tokenToText
+
+
+-- | Create a special error token. (e.g. fill in where there is no correct token to parse)
+-- Note that the position of the token has to be correct for correct computation of
+-- node spans.
+errTok :: Parser (Tok t) (Tok Token)
+errTok = mkTok <$> curPos
+ where curPos = tB <$> lookNext
+ tB Nothing = maxBound
+ tB (Just x) = tokBegin x
+ mkTok p = Tok (Special '!') 0 (startPosn {posnOfs = p})
diff --git a/src/Yi/Syntax/Strokes/Haskell.hs b/src/Yi/Syntax/Strokes/Haskell.hs
new file mode 100644
index 0000000..8e8aa61
--- /dev/null
+++ b/src/Yi/Syntax/Strokes/Haskell.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# OPTIONS_HADDOCK show-extensions #-}
+
+-- |
+-- Module : Yi.Syntax.Strokes.Haskell
+-- License : GPL-2
+-- Maintainer : yi-devel@googlegroups.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Produces 'Stroke's from a tree of tokens, used by some of the
+-- Haskell modes.
+
+module Yi.Syntax.Strokes.Haskell (getStrokes, tokenToAnnot) where
+
+import Prelude hiding (any, error, exp)
+
+import Data.Foldable (any)
+import Data.Monoid (Endo (..), (<>))
+import Yi.Debug (error, trace)
+import Yi.Lexer.Alex (Posn (posnOfs), Stroke, Tok (tokPosn, tokT), tokToSpan)
+import Yi.Lexer.Haskell
+import Yi.String (showT)
+import Yi.Style
+import Yi.Syntax (Point, Span)
+import Yi.Syntax.Haskell
+import Yi.Syntax.Tree (subtrees)
+
+-- TODO: (optimization) make sure we take in account the begin, so we
+-- don't return useless strokes
+getStrokes :: Point -> Point -> Point -> Tree TT -> [Stroke]
+getStrokes point begin _end t0 = trace (showT t0) result
+ where result = appEndo (getStr tkDConst point begin _end t0) []
+
+-- | Get strokes Module for module
+getStrokeMod :: Point -> Point -> Point -> PModuleDecl TT -> Endo [Stroke]
+getStrokeMod point begin _end tm@(PModuleDecl m na e w)
+ = pKW tm m <> getStr tkImport point begin _end na
+ <> getStrokes' e <> getStrokes' w
+ where getStrokes' = getStr tkDConst point begin _end
+ pKW b word | isErrN b = paintAtom errorStyle word
+ | otherwise = getStrokes' word
+
+-- | Get strokes for Imports
+getStrokeImp :: Point -> Point -> Point -> PImport TT -> Endo [Stroke]
+getStrokeImp point begin _end imp@(PImport m qu na t t')
+ = pKW imp m <> paintQu qu
+ <> getStr tkImport point begin _end na <> paintAs t <> paintHi t'
+ where getStrokes' = getStr tkDConst point begin _end
+ paintAs (Opt (Just (Bin (PAtom n c) tw)))
+ = one ((fmap (const keywordStyle) . tokToSpan) n) <> com c
+ <> getStr tkImport point begin _end tw
+ paintAs a = getStrokes' a
+ paintQu (Opt (Just (PAtom n c))) = one ((fmap (const keywordStyle) . tokToSpan) n) <> com c
+ paintQu a = getStrokes' a
+ paintHi (TC (Bin (Bin (PAtom n c) tw) r)) = one ((fmap (const keywordStyle) . tokToSpan) n)
+ <> com c <> getStr tkImport point begin _end tw
+ <> getStrokes' r
+ paintHi a = getStrokes' a
+ pKW b word | isErrN b = paintAtom errorStyle word
+ | otherwise = getStrokes' word
+
+-- | Get strokes for expressions and declarations
+getStr :: (TT -> Endo [Stroke]) -> Point -> Point -> Point -> Exp TT
+ -> Endo [Stroke]
+getStr tk point begin _end = getStrokes'
+ where getStrokes' :: Exp TT -> Endo [Stroke]
+ getStrokes' t@(PImport {}) = getStrokeImp point begin _end t
+ getStrokes' t@(PModuleDecl {}) = getStrokeMod point begin _end t
+ getStrokes' (PModule c m) = com c <> foldMap getStrokes' m
+ getStrokes' (PAtom t c) = tk t <> com c
+ getStrokes' (TS col ts') = tk col <> foldMap (getStr tkTConst point begin _end) ts'
+ getStrokes' (Modid t c) = tkImport t <> com c
+ getStrokes' (Paren (PAtom l c) g (PAtom r c'))
+ | isErr r = errStyle l <> getStrokesL g
+ -- left paren wasn't matched: paint it in red.
+ -- note that testing this on the "Paren" node actually forces the parsing of the
+ -- right paren, undermining online behaviour.
+ | posnOfs (tokPosn l) ==
+ point || posnOfs (tokPosn r) == point - 1
+ = pStyle hintStyle l <> com c <> getStrokesL g
+ <> pStyle hintStyle r <> com c'
+ | otherwise = tk l <> com c <> getStrokesL g
+ <> tk r <> com c'
+ getStrokes' (PError t _ c) = errStyle t <> com c
+ getStrokes' da@(PData kw na exp eq)
+ = pKW da kw <> getStrokes' na
+ <> getStrokes' exp <> getStrokes' eq
+ getStrokes' (PIn t l) = tk t <> getStrokesL l
+ getStrokes' (TC l) = getStr tkTConst point begin _end l
+ getStrokes' (DC (PAtom l c)) = tkDConst l <> com c
+ getStrokes' (DC r) = getStrokes' r -- do not color operator dc
+ getStrokes' g@(PGuard' t e t')
+ = pKW g t <> getStrokes' e <> getStrokes' t'
+ getStrokes' cl@(PClass e e' exp)
+ = pKW cl e <> getStrokes' e'
+ <> getStrokes' exp
+ getStrokes' t = foldMap getStrokes' (subtrees t) -- by default deal with subtrees
+ getStrokesL = foldMap getStrokes'
+ pKW b word | isErrN b = paintAtom errorStyle word
+ | otherwise = getStrokes' word
+
+-- Stroke helpers follows
+
+tokenToAnnot :: TT -> Maybe (Span String)
+tokenToAnnot = sequenceA . tokToSpan . fmap tokenToText
+
+ts :: TT -> Stroke
+ts = tokenToStroke
+
+pStyle :: StyleName -> TT -> Endo [Stroke]
+pStyle style = one . modStroke style . ts
+
+one :: Stroke -> Endo [Stroke]
+one x = Endo (x :)
+
+paintAtom :: StyleName -> Exp TT -> Endo [Stroke]
+paintAtom col (PAtom a c) = pStyle col a <> com c
+paintAtom _ _ = error "wrong usage of paintAtom"
+
+isErr :: TT -> Bool
+isErr = isErrorTok . tokT
+
+isErrN :: (Foldable v) => v TT -> Bool
+isErrN = any isErr
+--
+-- || not $ null $ isError' t
+
+errStyle :: TT -> Endo [Stroke]
+errStyle = pStyle errorStyle
+
+tokenToStroke :: TT -> Stroke
+tokenToStroke = fmap tokenToStyle . tokToSpan
+
+modStroke :: StyleName -> Stroke -> Stroke
+modStroke f = fmap (f `mappend`)
+
+com :: [TT] -> Endo [Stroke]
+com = foldMap tkDConst
+
+tk' :: (TT -> Bool) -> (TT -> Endo [Stroke]) -> TT -> Endo [Stroke]
+tk' f s t | isErr t = errStyle t
+ | tokT t `elem` fmap Reserved [As, Qualified, Hiding]
+ = one $ (fmap (const variableStyle) . tokToSpan) t
+ | f t = s t
+ | otherwise = one (ts t)
+
+tkTConst :: TT -> Endo [Stroke]
+tkTConst = tk' (const False) (const (Endo id))
+
+
+tkDConst :: TT -> Endo [Stroke]
+tkDConst = tk' ((== ConsIdent) . tokT) (pStyle dataConstructorStyle)
+
+tkImport :: TT -> Endo [Stroke]
+tkImport = tk' ((== ConsIdent) . tokT) (pStyle importStyle)
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
diff --git a/test/Yi/Lexer/HaskellSpec.hs b/test/Yi/Lexer/HaskellSpec.hs
new file mode 100644
index 0000000..d46048a
--- /dev/null
+++ b/test/Yi/Lexer/HaskellSpec.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
+{-# LANGUAGE IncoherentInstances, UndecidableInstances #-}
+{-# LANGUAGE StandaloneDeriving, QuasiQuotes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Yi.Lexer.HaskellSpec (main, spec) where
+
+
+import Control.Applicative ((<$>))
+import Prelude hiding (lex)
+import System.FilePath ((</>))
+import Test.Hspec
+import Yi.Buffer.Basic (Point(..))
+import Yi.Lexer.Alex
+import Yi.Lexer.Haskell
+import Yi.Lexer.Helpers.TH
+
+
+deriving instance Read OpType
+deriving instance Read ReservedType
+deriving instance Read CommentType
+deriving instance Read Token
+deriving instance Read Posn
+deriving instance Read Size
+deriving instance Read Point
+deriving instance Read a => Read (Tok a)
+
+newState :: AlexState HlState
+newState = AlexState initState 0 startPosn
+
+mkIndx :: String -> IndexedStr
+mkIndx = zip [1 ..]
+
+newInput :: String -> AlexInput
+newInput s = ('\n', [], mkIndx s)
+
+lex :: String -> [(AlexState HlState, TT)]
+lex s = unfoldLexer alexScanToken (newState, newInput s)
+
+lexTok :: String -> [TT]
+lexTok = map snd . lex
+
+lexToks :: String -> [Token]
+lexToks = map tokT . lexTok
+
+shouldLexToS :: FilePath -> [Token] -> Expectation
+shouldLexToS fp t = lexToks <$> readSample fp `shouldReturn` t
+
+lexesToS :: String -> [Token] -> Spec
+lexesToS s tt = it s $ s `shouldLexToS` tt
+
+readSample :: FilePath -> IO String
+readSample x = readFile $ "test" </> "test_data" </> x
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = do
+ describe "lexer tests" $ do
+ it "fill me in" pending
+ -- "Simple1.hs" `lexesToS` [ritFile|test/test_data/Simple1.hs_Token|]
+ -- "Simple1Unicode.hs" `lexesToS` [ritFile|test/test_data/Simple1Unicode.hs_Token|]
+ -- "UnicodeLiteral.hs" `lexesTo` [ritFile|test/test_data/UnicodeLiteral.hs_TToken|]
diff --git a/test/Yi/Lexer/Helpers.hs b/test/Yi/Lexer/Helpers.hs
new file mode 100644
index 0000000..d097f79
--- /dev/null
+++ b/test/Yi/Lexer/Helpers.hs
@@ -0,0 +1,2 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Yi.Lexer.Helpers where
diff --git a/test/Yi/Lexer/Helpers/TH.hs b/test/Yi/Lexer/Helpers/TH.hs
new file mode 100644
index 0000000..b4472c4
--- /dev/null
+++ b/test/Yi/Lexer/Helpers/TH.hs
@@ -0,0 +1,30 @@
+module Yi.Lexer.Helpers.TH where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+literally :: String -> Q Exp
+literally = return . LitE . StringL
+
+withRead :: String -> Q Exp
+withRead s = return $ AppE (VarE $ mkName "read") (LitE $ StringL s)
+
+lit :: QuasiQuoter
+lit = QuasiQuoter { quoteExp = literally
+ , quotePat = \s -> error s $ "quotePat: " ++ s
+ , quoteType = \s -> error $ "quoteType: " ++ s
+ , quoteDec = \s -> error $ "quoteDec: " ++ s}
+
+rlit :: QuasiQuoter
+rlit = QuasiQuoter { quoteExp = withRead
+ , quotePat = \s -> error s $ "quotePat: " ++ s
+ , quoteType = \s -> error $ "quoteType: " ++ s
+ , quoteDec = \s -> error $ "quoteDec: " ++ s}
+
+
+-- | Read file as-is.
+litFile :: QuasiQuoter
+litFile = quoteFile lit
+
+ritFile :: QuasiQuoter
+ritFile = quoteFile rlit
diff --git a/yi-mode-haskell.cabal b/yi-mode-haskell.cabal
new file mode 100644
index 0000000..a146bdc
--- /dev/null
+++ b/yi-mode-haskell.cabal
@@ -0,0 +1,87 @@
+-- This file has been generated from package.yaml by hpack version 0.14.0.
+--
+-- see: https://github.com/sol/hpack
+
+name: yi-mode-haskell
+version: 0.13
+synopsis: Yi editor haskell mode
+category: Yi
+homepage: https://github.com/yi-editor/yi#readme
+bug-reports: https://github.com/yi-editor/yi/issues
+maintainer: Yi developers <yi-devel@googlegroups.com>
+license: GPL-2
+build-type: Simple
+cabal-version: >= 1.10
+
+source-repository head
+ type: git
+ location: https://github.com/yi-editor/yi
+
+library
+ hs-source-dirs:
+ src
+ ghc-options: -Wall -ferror-spans
+ include-dirs:
+ src/Yi/Lexer
+ build-depends:
+ base >= 4.8 && < 5
+ , array
+ , binary >= 0.7
+ , data-default
+ , microlens-platform
+ , text
+ , yi-core
+ , yi-language
+ , yi-rope
+ exposed-modules:
+ Yi.Config.Default.HaskellMode
+ Yi.Lexer.Haskell
+ Yi.Lexer.LiterateHaskell
+ Yi.Mode.GHCi
+ Yi.Mode.Haskell
+ Yi.Mode.Haskell.Dollarify
+ Yi.Syntax.Haskell
+ Yi.Syntax.Paren
+ Yi.Syntax.Strokes.Haskell
+ other-modules:
+ Paths_yi_mode_haskell
+ default-language: Haskell2010
+
+test-suite spec
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ hs-source-dirs:
+ test
+ ghc-options: -Wall -ferror-spans -Wall
+ include-dirs:
+ src/Yi/Lexer
+ build-depends:
+ base >= 4.8 && < 5
+ , array
+ , binary >= 0.7
+ , data-default
+ , microlens-platform
+ , text
+ , yi-core
+ , yi-language
+ , yi-rope
+ , base
+ , array
+ , binary
+ , containers
+ , data-default
+ , filepath
+ , hashable >=1.1.2.5
+ , hspec
+ , microlens-platform
+ , pointedlist >= 0.5
+ , regex-base ==0.93.*
+ , regex-tdfa >= 1.1 && <1.3
+ , template-haskell >= 2.4
+ , transformers-base
+ , unordered-containers >= 0.1.3 && < 0.3
+ , QuickCheck == 2.*
+ , yi-mode-haskell
+ other-modules:
+ Yi.Lexer.HaskellSpec Yi.Lexer.Helpers Yi.Lexer.Helpers.TH
+ default-language: Haskell2010