ParserBox.hs

{-# language NamedFieldPuns #-}
{-# language TypeSynonymInstances #-}
{-# language FlexibleInstances #-}
{-# language OverloadedStrings #-}
{-# language TypeFamilies #-}
{-# language LambdaCase #-}

import Control.Applicative (some)
import Control.Monad (guard, void)

import Data.Monoid ((<>))
import Data.String (IsString (fromString))

import Text.ParserCombinators.Parsec

instance (a ~ ()) => IsString (Parser a) where
    fromString = tok

data Sequence c a = Sequence
    { element     :: Parser a
    , open        :: Parser ()
    , close       :: Parser ()
    , sep         :: Parser ()
    , comments    :: Comments c
    }

data Comments c = Comments
    { commentUp   :: Parser c
    , commentDown :: Parser c
    }

data Commented c a = Commented
    { before       :: c
    , getCommented :: a
    , after        :: c
    }
    deriving (Show)

commented :: Monoid c => Comments c -> Parser a -> Parser (Commented c a)
commented Comments {commentUp, commentDown} parser = do
    cb  <- orEmpty commentDown
    res <- parser
    ca  <- orEmpty commentUp
    return (Commented cb res ca)

sequenceOf :: Monoid c => Sequence c a -> Parser [Commented c a]
sequenceOf Sequence {element, open, close, sep, comments = Comments {commentUp, commentDown}} = do
    _    <- open
    cb0  <- orEmpty commentDown
    _    <- optional sep
    cb1  <- orEmpty commentDown
    list <- loop (cb0 <> cb1)
    _    <- close
    return list
  where
    loop cb = do
        cb1 <- orEmpty commentDown
        e   <- element
        ca  <- orEmpty commentUp
        (ca1, es) <-
            do  try $ do
                    ca0 <- orEmpty commentUp
                    cb0 <- orEmpty commentDown
                    (ca1, es) <- do
                        _   <- sep
                        ca1 <- orEmpty commentUp
                        cb1 <- orEmpty commentDown
                        es  <- loop (cb0 <> cb1)
                        return (ca1, es)
                    return (ca0 <> ca1, es)
          <|>
            do  return (mempty, [])

        return (Commented (cb <> cb1) e (ca <> ca1) : es)
      <|>
        return []

orEmpty :: Monoid m => Parser m -> Parser m
orEmpty = option mempty

gentok :: Parser () -> String -> Parser ()
gentok spaces s = try (string s) >> spaces

tok = gentok spaces

data CharacterClass
    = OneOf  [Char]
    | NoneOf [Char]
    | CharacterClass `And` CharacterClass
    | CharacterClass `Or`  CharacterClass
    | Not CharacterClass
    | The (Char -> Bool)

spaceC = OneOf " \t\n\r"
digitC = OneOf ['0'.. '9']
punctC = OneOf "()[]{};."
delimC = OneOf ['"']

matches :: CharacterClass -> Char -> Bool
matches = \case
    OneOf  cs -> (`elem`    cs)
    NoneOf cs -> (`notElem` cs)
    l `And` r -> (&&) <$> matches l <*> matches r
    l `Or`  r -> (||) <$> matches l <*> matches r
    Not cs    -> not . matches cs

genName :: CharacterClass -> CharacterClass -> String -> Parser String
genName start next reservedWordString = do
    try $ do
        first <-        satisfy $ matches start
        rest  <- many $ satisfy $ matches next

        let name = first : rest

        guard (name `notElem` reservedWords)

        return name

  <?> "name"
  where
    reservedWords = words reservedWordString

float :: Parser Double
float = do
    try $ do
        start <- some $ oneOf ['0'.. '9']
        rest  <- option "" $ string "." <> many (oneOf ['0'.. '9']) <> pure "0"
        return $ read $ start ++ rest

main = do
    let
      name = genName
        (Not (spaceC `Or` punctC `Or` delimC `Or` digitC))
        (Not (spaceC `Or` punctC `Or` delimC))
        "let in case of with -> \\ ="

      list = sequenceOf Sequence
        { open        = "("
        , close       = ")"
        , sep         = ","
        , element     = "X" >> return 1
        , comments    = Comments
            { commentUp   = "A" >> return "A"
            , commentDown = "B" >> return "B"
            }
        }

    print (parse list "-" "()")
    print (parse list "-" "(,)")
    print (parse list "-" "(B,B XA)")
    print (parse list "-" "(BXA)")
    print (parse list "-" "(BXA, )")
    print (parse list "-" "(BXAB,ABXA)")
    print (parse list "-" "(BXAB, ABXA,A)")
    print (parse list "-" "(, X, X)")
    print (parse list "-" "(, X, X,)")