ExprParser.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-|
Module      : Text.Pretty.Simple.Internal.ExprParser
Copyright   : (c) Dennis Gosnell, 2016
License     : BSD-style (see LICENSE file)
Maintainer  : cdep.illabout@gmail.com
Stability   : experimental
Portability : POSIX

-}
module Text.Pretty.Simple.Internal.ExprParser
  where

import Text.Pretty.Simple.Internal.Expr (CommaSeparated(..), Expr(..))
import Control.Arrow (first)
import Data.Char (isAlpha, isDigit)

-- | 'testString1' and 'testString2' are convenient to use in GHCi when playing
-- around with how parsing works.
testString1 :: String
testString1 = "Just [TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}, TextInput {textInputClass = Just (Class {unClass = \"class\"}), textInputId = Just (Id {unId = \"id\"}), textInputName = Just (Name {unName = \"name\"}), textInputValue = Just (Value {unValue = \"value\"}), textInputPlaceholder = Just (Placeholder {unPlaceholder = \"placeholder\"})}]"

-- | See 'testString1'.
testString2 :: String
testString2 = "some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)"

expressionParse :: String -> [Expr]
expressionParse = fst . parseExprs

parseExpr :: String -> (Expr, String)
parseExpr ('(':rest) = first (Parens . CommaSeparated) $ parseCSep ')' rest
parseExpr ('[':rest) = first (Brackets . CommaSeparated) $ parseCSep ']' rest
parseExpr ('{':rest) = first (Braces . CommaSeparated) $ parseCSep '}' rest
parseExpr ('"':rest) = first StringLit $ parseStringLit rest
parseExpr ('\'':rest) = first CharLit $ parseCharLit rest
parseExpr (c:rest) | isDigit c = first NumberLit $ parseNumberLit c rest
parseExpr other      = first Other $ parseOther other

-- | Parse multiple expressions.
--
-- >>> parseExprs "Just 'a'"
-- ([Other "Just ",CharLit "a"],"")
--
-- Handle escaped characters correctly
--
-- >>> parseExprs $ "Foo \"hello \\\"world!\""
-- ([Other "Foo ",StringLit "hello \\\"world!"],"")
-- >>> parseExprs $ "'\\''"
-- ([CharLit "\\'"],"")
parseExprs :: String -> ([Expr], String)
parseExprs [] = ([], "")
parseExprs s@(c:_)
  | c `elem` (")]}," :: String) = ([], s)
  | otherwise = let (parsed, rest') = parseExpr s
                    (toParse, rest) = parseExprs rest'
                 in (parsed : toParse, rest)

parseCSep :: Char -> String -> ([[Expr]], String)
parseCSep _ [] = ([], "")
parseCSep end s@(c:cs)
  | c == end = ([], cs)
  -- Mismatch condition; if the end does not match, there is a mistake
  -- Perhaps there should be a Missing constructor for Expr
  | c `elem` (")]}" :: String) = ([], s)
  | c == ',' = parseCSep end cs
  | otherwise = let (parsed, rest') = parseExprs s
                    (toParse, rest) = parseCSep end rest'
                 in (parsed : toParse, rest)

-- | Parse string literals until a trailing double quote.
--
-- >>> parseStringLit "foobar\" baz"
-- ("foobar"," baz")
--
-- Keep literal back slashes:
--
-- >>> parseStringLit "foobar\\\" baz\" after"
-- ("foobar\\\" baz"," after")
parseStringLit :: String -> (String, String)
parseStringLit [] = ("", "")
parseStringLit ('"':rest) = ("", rest)
parseStringLit ('\\':c:cs) = ('\\':c:cs', rest)
  where (cs', rest) = parseStringLit cs
parseStringLit (c:cs) = (c:cs', rest)
  where (cs', rest) = parseStringLit cs

-- | Parse character literals until a trailing single quote.
--
-- >>> parseCharLit "a' foobar"
-- ("a"," foobar")
--
-- Keep literal back slashes:
--
-- >>> parseCharLit "\\'' hello"
-- ("\\'"," hello")
parseCharLit :: String -> (String, String)
parseCharLit [] = ("", "")
parseCharLit ('\'':rest) = ("", rest)
parseCharLit ('\\':c:cs) = ('\\':c:cs', rest)
  where (cs', rest) = parseCharLit cs
parseCharLit (c:cs) = (c:cs', rest)
  where (cs', rest) = parseCharLit cs

-- | Parses integers and reals, like @123@ and @45.67@.
--
-- To be more precise, any numbers matching the regex @\\d+(\\.\\d+)?@ should
-- get parsed by this function.
--
-- >>> parseNumberLit '3' "456hello world []"
-- ("3456","hello world []")
-- >>> parseNumberLit '0' ".12399880 foobar"
-- ("0.12399880"," foobar")
parseNumberLit :: Char -> String -> (String, String)
parseNumberLit firstDigit rest1 =
  case rest2 of
    []        -> (firstDigit:remainingDigits, "")
    '.':rest3 ->
      let (digitsAfterDot, rest4) = span isDigit rest3
      in ((firstDigit : remainingDigits) ++ ('.' : digitsAfterDot), rest4)
    _         -> (firstDigit:remainingDigits, rest2)
  where
    remainingDigits :: String
    rest2 :: String
    (remainingDigits, rest2) = span isDigit rest1

-- | This function consumes input, stopping only when it hits a special
-- character or a digit.  However, if the digit is in the middle of a
-- Haskell-style identifier (e.g. @foo123@), then keep going
-- anyway.
--
-- This is almost the same as the function
--
-- > parseOtherSimple = span $ \c ->
-- >   notElem c ("{[()]}\"," :: String) && not (isDigit c) && (c /= '\'')
--
-- except 'parseOther' ignores digits and single quotes that appear in
-- Haskell-like identifiers.
--
-- >>> parseOther "hello world []"
-- ("hello world ","[]")
-- >>> parseOther "hello234 world"
-- ("hello234 world","")
-- >>> parseOther "hello 234 world"
-- ("hello ","234 world")
-- >>> parseOther "hello{[ 234 world"
-- ("hello","{[ 234 world")
-- >>> parseOther "H3110 World"
-- ("H3110 World","")
-- >>> parseOther "Node' (Leaf' 1) (Leaf' 2)"
-- ("Node' ","(Leaf' 1) (Leaf' 2)")
-- >>> parseOther "I'm One"
-- ("I'm One","")
-- >>> parseOther "I'm 2"
-- ("I'm ","2")
parseOther :: String -> (String, String)
parseOther = go False
  where
    go
      :: Bool
      -- ^ in an identifier?
      -> String
      -> (String, String)
    go _ [] = ("", "")
    go insideIdent cs@(c:cs')
      | c `elem` ("{[()]}\"," :: String) = ("", cs)
      | ignoreInIdent c && not insideIdent = ("", cs)
      | insideIdent = first (c :) (go (isIdentRest c) cs')
      | otherwise = first (c :) (go (isIdentBegin c) cs')

    isIdentBegin :: Char -> Bool
    isIdentBegin '_' = True
    isIdentBegin c = isAlpha c

    isIdentRest :: Char -> Bool
    isIdentRest '_' = True
    isIdentRest '\'' = True
    isIdentRest c = isAlpha c || ignoreInIdent c

    ignoreInIdent :: Char -> Bool
    ignoreInIdent x = isDigit x || x == '\''