my megasec parsers

.gitignore

dist
.stack-work

ghci.hs

import Control.Monad
import Control.Applicative
import Data.List
import System.Environment
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.String

import Debug.Trace
t :: Show a => a -> a
t = show >>= trace
s :: String -> String
s = id >>= trace

p pa = parse pa ""
ps pa = parse pa

str :: Parser String
str = between quote quote (many $ (noneOf "\\\"") <|> (char '\'' *> noneOf "\""))
    where quote = char '"'

k :: Parser String
k = many $ (noneOf "x\\\"") <|> (char '\\' *> noneOf "\"")

l :: Parser String
l = many $ (noneOf "x\\\"") <|> char 'x'

input

t: "one"
t: (seven eight)
t: <six>

f: "two'
f: <three
f: <four<
f: <five)

t: zn: test
t: !test

t: str: "test"
t: str: "t\"est"
f: str: "test"x
f: str: "t\"

t: sentence-1: "foo" "bar"
f: sentence-1: "foo""bar"
f: sentence-1: "foo" bar
t: sentence-2: "foo" bar
t: sentence-2: "foo" b\ \"ar 'test' 'a b' thisescapes\\well
f: sentence-2: "foo" b'ar

f: btw3: s/what/the
t: btw3: s/what/the/
t: btw3: s/what/the/gi
f: btw3: s/what/the/fuck

Makefile

all:
	find -name '*.hs' | write-do sh -c 'clear; stack build && stack exec megasec < input'

MegasecMain.hs

{-# LANGUAGE TupleSections #-}

import Control.Applicative
import Control.Monad
import Data.Either
import Data.List
import System.Environment
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.String

import MSed
import MShellish
import MTesting
import MZn

prefix :: String -> String -> String
prefix prefixStr = unlines . map (prefixStr ++) . lines

parser :: Parser String
parser = choice . map (<* eof) $
    [ string "str: " *> str '"'
    , string "sentence-1: " *> (fmap show $ sentence (str '"'))
    , string "sentence-2: " *> (fmap show $ shellish)
    , string "btw3: " *> (fmap show sed)
    , enclosed
    , addressed]

explain :: String -> Either ParseError String -> IO ()
explain input parse = do
    putStrLn $ color ("¬ " ++ input)
    putStrLn . either (cprefix "!··· " . show) (cprefix "»··· ") $ parse
    where
        cprefix p = (const color id) . prefix p
        color =
            if (input !! 0 == 't') == isLeft parse
            then ("\x1b[31m" ++)
            else ("\x1b[32m" ++)

run :: String -> (String, Either ParseError String)
run str = (str, ) $ parse (indication *> parser) "input" str
    where indication = (string "t" <|> string "f") <* string ": "

main = do
    c <- getContents
    mapM_ (uncurry explain . run) . filter (not . null) . takeWhile (/= "END") $ lines c
    -- insert color resetting here

MSed.hs

module MSed where

import Control.Applicative
import Control.Monad
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.String

between3 :: Parser a -> Parser b -> Parser (b, b)
between3 lim p = do
    lim; a <- p; lim; b <- p; lim
    return (a, b)

sed :: Parser ((String, String), String)
sed = (,) <$> (string "s" *> body) <*> (many $ oneOf "gi")
    where body = between3 (string "/") (many $ noneOf "/")

MShellish.hs

module MShellish where

import Control.Applicative
import Control.Monad
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.String

escaped :: String -> Parser String
escaped quotes = many $ (char '\\' *> anyChar) <|> (noneOf quotes)

str :: Char -> Parser String
str = (\q -> between (char q) (char q) (escaped [q]))

sentence :: Parser String -> Parser [String]
sentence from = sepBy1 from (skipSome spaceChar)

shellish :: Parser [String]
shellish = sentence $ str '\"' <|> str '\'' <|> escaped " \"'"

MTesting.hs

module MTesting where

import Control.Applicative
import Control.Monad
import Data.List
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.String

import Debug.Trace
t :: Show a => a -> a
t = show >>= trace
s :: String -> String
s = id >>= trace

translateSome :: Eq a => [a] -> a -> a
translateSome hay needle = maybe needle id $ do
    idx <- elemIndex needle hay
    Just $ hay !! (idx + 1)

opens = "([*<\"'"
substs = "()[]<>"

enclosed :: Parser String
enclosed = do
    open <- oneOf opens
    let end = translateSome substs open
    many (noneOf $ return end) <* char end

MZn.hs

module MZn where

import Control.Applicative
import Control.Monad
import Text.Megaparsec
import Text.Megaparsec.Expr
import Text.Megaparsec.String

addressed :: Parser String
addressed = (byName <|> byPrefix) *> many anyChar
    where
        byName = string "zn" *> oneOf ":," *> space
        byPrefix = void $ oneOf "!,"

ParsecMain.hs

import Control.Monad
import Data.List
import System.Environment
import Text.Parsec
import Text.Parsec.Char
import Text.Parsec.String

translateSome :: Eq a => [a] -> a -> a
translateSome hay needle = maybe needle id $ do
    idx <- elemIndex needle hay
    Just $ hay !! (idx + 1)

opens = "([*<\"'"
substs = "()[]<>"

enclosed :: Parser String
enclosed = do
    open <- oneOf opens
    let end = translateSome substs open
    many (noneOf $ return end) <* char end

addressed :: Parser ()
addressed = undefined -- byName <|> byPrefix
    where
        byName = undefined -- string "zn" *> oneOf ":," *> spaces
        byPrefix = undefined -- oneOf "!,"

main = do
    c <- getContents
    mapM_ (print . parse enclosed "") $ lines c

{--
main = do
    c <- getContents
    mapM_ (print . choice [enclosed, addressed] "") $ lines c
--}

pkg.cabal

name:                pkg
version:             0.1.0.0
synopsis:            IRC bot
description:         Xn's rival
author:              siers
maintainer:          @gmail.com
copyright:           Copyleft
build-type:          Simple
cabal-version:       >=1.20

executable parsec
  hs-source-dirs:      .

  main-is:             ParsecMain.hs

  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  default-extensions:  OverloadedStrings
  default-language:    Haskell2010
  build-depends:       base
                     , aeson
                     , parsec

executable megasec
  hs-source-dirs:      .

  main-is:             MegasecMain.hs
  other-modules:       MSed
                     , MShellish
                     , MTesting
                     , MZn

  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
  default-extensions:  OverloadedStrings
  default-language:    Haskell2010
  build-depends:       base
                     , aeson
                     , megaparsec

stack.yaml

# This file was automatically generated by stack init
# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/

# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-6.14

# Local packages, usually specified by relative directory name
packages:
- '.'
extra-deps: []

# Override default flag values for local packages and extra-deps
flags: {}

# Extra package databases containing global packages
extra-package-dbs: []

# Control whether we use the GHC we find on the path
system-ghc: false

# ghc-options:
#    "*": -fwarn-unused-imports

# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 1.0.0

# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64

# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]

# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor