yi-mode-haskell-0.14.1/src/0000755000000000000000000000000013136407445013545 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/0000755000000000000000000000000013136407445014126 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Config/0000755000000000000000000000000013136407445015333 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Config/Default/0000755000000000000000000000000013136407445016717 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Lexer/0000755000000000000000000000000013136407445015205 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Mode/0000755000000000000000000000000013136407445015012 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Mode/Haskell/0000755000000000000000000000000013136407445016375 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Syntax/0000755000000000000000000000000013136407445015414 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Syntax/Strokes/0000755000000000000000000000000013136407445017046 5ustar0000000000000000yi-mode-haskell-0.14.1/src/Yi/Config/Default/HaskellMode.hs0000644000000000000000000000041013136407445021436 0ustar0000000000000000module Yi.Config.Default.HaskellMode (configureHaskellMode) where import Yi.Config.Simple (ConfigM, addMode) import Yi.Mode.Haskell configureHaskellMode :: ConfigM () configureHaskellMode = do addMode literateMode addMode preciseMode addMode cleverMode yi-mode-haskell-0.14.1/src/Yi/Lexer/Haskell.x0000644000000000000000000005142613136407445016771 0ustar0000000000000000-- -*- 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+ ; { "{-" { 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" } yi-mode-haskell-0.14.1/src/Yi/Lexer/LiterateHaskell.x0000644000000000000000000002235113136407445020456 0ustar0000000000000000-- -*- 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+ ; { "{-" { 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-} } } { "\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 } } { [\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" } yi-mode-haskell-0.14.1/src/Yi/Mode/GHCi.hs0000644000000000000000000000607713136407445016132 0ustar0000000000000000{-# 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 yi-mode-haskell-0.14.1/src/Yi/Mode/Haskell.hs0000644000000000000000000004771013136407445016742 0ustar0000000000000000{-# 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' yi-mode-haskell-0.14.1/src/Yi/Mode/Haskell/Dollarify.hs0000644000000000000000000001561713136407445020670 0ustar0000000000000000{-# 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 yi-mode-haskell-0.14.1/src/Yi/Syntax/Haskell.hs0000644000000000000000000006544713136407445017353 0ustar0000000000000000{-# 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}) yi-mode-haskell-0.14.1/src/Yi/Syntax/Paren.hs0000644000000000000000000001526013136407445017021 0ustar0000000000000000{-# 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}) yi-mode-haskell-0.14.1/src/Yi/Syntax/Strokes/Haskell.hs0000644000000000000000000001445613136407445020777 0ustar0000000000000000{-# 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) yi-mode-haskell-0.14.1/Setup.hs0000644000000000000000000000012613136407445014411 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main :: IO () main = defaultMain yi-mode-haskell-0.14.1/yi-mode-haskell.cabal0000644000000000000000000000241113137144536016724 0ustar0000000000000000-- This file has been generated from package.yaml by hpack version 0.17.0. -- -- see: https://github.com/sol/hpack name: yi-mode-haskell version: 0.14.1 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 license: GPL-2 build-type: Simple cabal-version: >= 1.10 extra-source-files: src/Yi/Lexer/common.hsinc 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 , filepath , microlens-platform , text , yi-core , yi-language , yi-rope build-tools: alex >= 3.0.3 && < 3.2.0 || >= 3.2.1 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 yi-mode-haskell-0.14.1/src/Yi/Lexer/common.hsinc0000644000000000000000000000705013136407445017525 0ustar0000000000000000-- -*- Haskell -*- -- The include file for alex-generated syntax highlighters. Because alex -- declares its own types, any wrapper must have the highlighter in scope... -- so it must be included. Doubleplusyuck. #define IBOX(n) (I# (n)) #define GEQ_(x, y) (tagToEnum# (x >=# y)) #define EQ_(x, y) (tagToEnum# (x ==# y)) -- | Scan one token. Return (maybe) a token and a new state. alexScanToken :: (AlexState HlState, AlexInput) -> Maybe (Tok Token, (AlexState HlState, AlexInput)) alexScanToken (AlexState state lookedOfs pos, inp@(_prevCh,_bs,str)) = let (scn,lookahead) = alexScanUser' state inp (stateToInit state) lookedOfs' = max lookedOfs (posnOfs pos +~ Size lookahead) in case scn of AlexEOF -> Nothing AlexError inp' -> Nothing AlexSkip inp' len -> let chunk = take (fromIntegral len) str in alexScanToken (AlexState state lookedOfs' (moveStr pos chunk), inp') AlexToken inp' len act -> let (state', tokValue) = act chunk state chunk = take (fromIntegral len) str newPos = moveStr pos chunk in Just (Tok tokValue (posnOfs newPos ~- posnOfs pos) pos, (AlexState state' lookedOfs' newPos, inp')) alexScan' input (I# (sc)) = alexScanUser' undefined input (I# (sc)) alexScanUser' user input (I# (sc)) = case alex_scan_tkn' user input 0# input sc AlexNone of (AlexNone, input', lookahead) -> case alexGetByte input of Nothing -> (AlexEOF, lookahead) Just _ -> (AlexError input', lookahead) (AlexLastSkip input'' len, _, lookahead) -> (AlexSkip input'' len, lookahead) #if MIN_TOOL_VERSION_alex(3,2,0) (AlexLastAcc k input'' len, _, lookahead) -> (AlexToken input'' len (alex_actions ! k), lookahead) #else (AlexLastAcc k input'' len, _, lookahead) -> (AlexToken input'' len k, lookahead) #endif -- Same as alex_scan_tkn, but also return the length of lookahead. alex_scan_tkn' user orig_input len input s last_acc = input `seq` -- strict in the input let new_acc = check_accs (alex_accept `quickIndex` IBOX(s)) in new_acc `seq` case alexGetByte input of Nothing -> (new_acc, input, IBOX(len)) Just (c, new_input) -> let base = alexIndexInt32OffAddr alex_base s ord_c = case fromIntegral c of (I# x) -> x offset = (base +# ord_c) check = alexIndexInt16OffAddr alex_check offset new_s = if GEQ_(offset, 0#) && EQ_(check, ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s new_len = if c < 0x80 || c >= 0xC0 then len +# 1# else len in case new_s of -1# -> (new_acc, input, IBOX(new_len)) -- on an error, we want to keep the input *before* the -- character that failed, not after. -- (but still, we looked after) _ -> alex_scan_tkn' user orig_input new_len new_input new_s new_acc where check_accs (AlexAccNone) = last_acc check_accs (AlexAcc a ) = AlexLastAcc a input IBOX(len) check_accs (AlexAccSkip) = AlexLastSkip input IBOX(len) #ifndef NO_ALEX_CONTEXTS check_accs (AlexAccPred a predx rest) | predx user orig_input IBOX(len) input = AlexLastAcc a input IBOX(len) | otherwise = check_accs rest check_accs (AlexAccSkipPred predx rest) | predx user orig_input IBOX(len) input = AlexLastSkip input IBOX(len) | otherwise = check_accs rest #endif c = actionConst m = actionAndModify ms = actionStringAndModify cs = actionStringConst