{-# 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 :: String
testString1 = String
"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 :: String
testString2 = String
"some stuff (hello [\"dia\\x40iahello\", why wh, bye] ) (bye)"

expressionParse :: String -> [Expr]
expressionParse :: String -> [Expr]
expressionParse = ([Expr], String) -> [Expr]
forall a b. (a, b) -> a
fst (([Expr], String) -> [Expr])
-> (String -> ([Expr], String)) -> String -> [Expr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ([Expr], String)
parseExprs

parseExpr :: String -> (Expr, String)
parseExpr :: String -> (Expr, String)
parseExpr (Char
'(':String
rest) = ([[Expr]] -> Expr) -> ([[Expr]], String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (CommaSeparated [Expr] -> Expr
Parens (CommaSeparated [Expr] -> Expr)
-> ([[Expr]] -> CommaSeparated [Expr]) -> [[Expr]] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Expr]] -> CommaSeparated [Expr]
forall a. [a] -> CommaSeparated a
CommaSeparated) (([[Expr]], String) -> (Expr, String))
-> ([[Expr]], String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ Char -> String -> ([[Expr]], String)
parseCSep Char
')' String
rest
parseExpr (Char
'[':String
rest) = ([[Expr]] -> Expr) -> ([[Expr]], String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (CommaSeparated [Expr] -> Expr
Brackets (CommaSeparated [Expr] -> Expr)
-> ([[Expr]] -> CommaSeparated [Expr]) -> [[Expr]] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Expr]] -> CommaSeparated [Expr]
forall a. [a] -> CommaSeparated a
CommaSeparated) (([[Expr]], String) -> (Expr, String))
-> ([[Expr]], String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ Char -> String -> ([[Expr]], String)
parseCSep Char
']' String
rest
parseExpr (Char
'{':String
rest) = ([[Expr]] -> Expr) -> ([[Expr]], String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (CommaSeparated [Expr] -> Expr
Braces (CommaSeparated [Expr] -> Expr)
-> ([[Expr]] -> CommaSeparated [Expr]) -> [[Expr]] -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Expr]] -> CommaSeparated [Expr]
forall a. [a] -> CommaSeparated a
CommaSeparated) (([[Expr]], String) -> (Expr, String))
-> ([[Expr]], String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ Char -> String -> ([[Expr]], String)
parseCSep Char
'}' String
rest
parseExpr (Char
'"':String
rest) = (String -> Expr) -> (String, String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> Expr
StringLit ((String, String) -> (Expr, String))
-> (String, String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
parseStringLit String
rest
parseExpr (Char
'\'':String
rest) = (String -> Expr) -> (String, String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> Expr
CharLit ((String, String) -> (Expr, String))
-> (String, String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
parseCharLit String
rest
parseExpr (Char
c:String
rest) | Char -> Bool
isDigit Char
c = (String -> Expr) -> (String, String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> Expr
NumberLit ((String, String) -> (Expr, String))
-> (String, String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ Char -> String -> (String, String)
parseNumberLit Char
c String
rest
parseExpr String
other      = (String -> Expr) -> (String, String) -> (Expr, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> Expr
Other ((String, String) -> (Expr, String))
-> (String, String) -> (Expr, String)
forall a b. (a -> b) -> a -> b
$ String -> (String, String)
parseOther String
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 :: String -> ([Expr], String)
parseExprs [] = ([], String
"")
parseExprs s :: String
s@(Char
c:String
_)
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
")]}," :: String) = ([], String
s)
  | Bool
otherwise = let (Expr
parsed, String
rest') = String -> (Expr, String)
parseExpr String
s
                    ([Expr]
toParse, String
rest) = String -> ([Expr], String)
parseExprs String
rest'
                 in (Expr
parsed Expr -> [Expr] -> [Expr]
forall a. a -> [a] -> [a]
: [Expr]
toParse, String
rest)

parseCSep :: Char -> String -> ([[Expr]], String)
parseCSep :: Char -> String -> ([[Expr]], String)
parseCSep Char
_ [] = ([], String
"")
parseCSep Char
end s :: String
s@(Char
c:String
cs)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
end = ([], String
cs)
  -- Mismatch condition; if the end does not match, there is a mistake
  -- Perhaps there should be a Missing constructor for Expr
  | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
")]}" :: String) = ([], String
s)
  | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' = Char -> String -> ([[Expr]], String)
parseCSep Char
end String
cs
  | Bool
otherwise = let ([Expr]
parsed, String
rest') = String -> ([Expr], String)
parseExprs String
s
                    ([[Expr]]
toParse, String
rest) = Char -> String -> ([[Expr]], String)
parseCSep Char
end String
rest'
                 in ([Expr]
parsed [Expr] -> [[Expr]] -> [[Expr]]
forall a. a -> [a] -> [a]
: [[Expr]]
toParse, String
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 :: String -> (String, String)
parseStringLit [] = (String
"", String
"")
parseStringLit (Char
'"':String
rest) = (String
"", String
rest)
parseStringLit (Char
'\\':Char
c:String
cs) = (Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs', String
rest)
  where (String
cs', String
rest) = String -> (String, String)
parseStringLit String
cs
parseStringLit (Char
c:String
cs) = (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs', String
rest)
  where (String
cs', String
rest) = String -> (String, String)
parseStringLit String
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 :: String -> (String, String)
parseCharLit [] = (String
"", String
"")
parseCharLit (Char
'\'':String
rest) = (String
"", String
rest)
parseCharLit (Char
'\\':Char
c:String
cs) = (Char
'\\'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs', String
rest)
  where (String
cs', String
rest) = String -> (String, String)
parseCharLit String
cs
parseCharLit (Char
c:String
cs) = (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs', String
rest)
  where (String
cs', String
rest) = String -> (String, String)
parseCharLit String
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 :: Char -> String -> (String, String)
parseNumberLit Char
firstDigit String
rest1 =
  case String
rest2 of
    []        -> (Char
firstDigitChar -> String -> String
forall a. a -> [a] -> [a]
:String
remainingDigits, String
"")
    Char
'.':String
rest3 ->
      let (String
digitsAfterDot, String
rest4) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
rest3
      in ((Char
firstDigit Char -> String -> String
forall a. a -> [a] -> [a]
: String
remainingDigits) String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
digitsAfterDot), String
rest4)
    String
_         -> (Char
firstDigitChar -> String -> String
forall a. a -> [a] -> [a]
:String
remainingDigits, String
rest2)
  where
    remainingDigits :: String
    rest2 :: String
    (String
remainingDigits, String
rest2) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
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 :: String -> (String, String)
parseOther = Bool -> String -> (String, String)
go Bool
False
  where
    go
      :: Bool
      -- ^ in an identifier?
      -> String
      -> (String, String)
    go :: Bool -> String -> (String, String)
go Bool
_ [] = (String
"", String
"")
    go Bool
insideIdent cs :: String
cs@(Char
c:String
cs')
      | Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"{[()]}\"," :: String) = (String
"", String
cs)
      | Char -> Bool
ignoreInIdent Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
insideIdent = (String
"", String
cs)
      | Bool
insideIdent = (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:) (Bool -> String -> (String, String)
go (Char -> Bool
isIdentRest Char
c) String
cs')
      | Bool
otherwise = (String -> String) -> (String, String) -> (String, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
:) (Bool -> String -> (String, String)
go (Char -> Bool
isIdentBegin Char
c) String
cs')

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

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

    ignoreInIdent :: Char -> Bool
    ignoreInIdent :: Char -> Bool
ignoreInIdent Char
x = Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''