{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.SCargot.Language.HaskLike
  ( -- $info
    HaskLikeAtom(..)
  , haskLikeParser
  , haskLikePrinter
  , locatedHaskLikeParser
  , locatedHaskLikePrinter
    -- * Individual Parsers
  , parseHaskellString
  , parseHaskellFloat
  , parseHaskellInt
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<$))
#endif
import           Data.Maybe (catMaybes)
import           Data.String (IsString(..))
import           Data.Text (Text, pack)
import           Text.Parsec
import           Text.Parsec.Text (Parser)

import           Prelude hiding (concatMap)

import Data.SCargot.Common
import Data.SCargot.Repr.Basic (SExpr)
import Data.SCargot (SExprParser, SExprPrinter, mkParser, flatPrint)

{- $info

This module is intended for simple, ad-hoc configuration or data
formats that might not need their on rich structure but might benefit
from a few various kinds of literals. The 'haskLikeParser' understands
identifiers as defined by R5RS, as well as string, integer, and
floating-point literals as defined by the Haskell 2010 spec. It does
__not__ natively understand other data types, such as booleans,
vectors, bitstrings.

-}


-- | An atom type that understands Haskell-like values as well as
--   Scheme-like identifiers.
data HaskLikeAtom
  = HSIdent  Text  -- ^ An identifier, parsed according to the R5RS Scheme
                   --   standard
  | HSString Text  -- ^ A string, parsed according to the syntax for string
                   --   literals in the Haskell report
  | HSInt Integer  -- ^ An arbitrary-sized integer value, parsed according to
                   --   the syntax for integer literals in the Haskell report
  | HSFloat Double -- ^ A double-precision floating-point value, parsed
                   --   according to the syntax for floats in the Haskell
                   --   report
    deriving (HaskLikeAtom -> HaskLikeAtom -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HaskLikeAtom -> HaskLikeAtom -> Bool
$c/= :: HaskLikeAtom -> HaskLikeAtom -> Bool
== :: HaskLikeAtom -> HaskLikeAtom -> Bool
$c== :: HaskLikeAtom -> HaskLikeAtom -> Bool
Eq, Int -> HaskLikeAtom -> ShowS
[HaskLikeAtom] -> ShowS
HaskLikeAtom -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HaskLikeAtom] -> ShowS
$cshowList :: [HaskLikeAtom] -> ShowS
show :: HaskLikeAtom -> String
$cshow :: HaskLikeAtom -> String
showsPrec :: Int -> HaskLikeAtom -> ShowS
$cshowsPrec :: Int -> HaskLikeAtom -> ShowS
Show)

instance IsString HaskLikeAtom where
  fromString :: String -> HaskLikeAtom
fromString = Text -> HaskLikeAtom
HSIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

instance IsString (Located HaskLikeAtom) where
  fromString :: String -> Located HaskLikeAtom
fromString = (forall a. Location -> a -> Located a
At Location
dLocation) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> HaskLikeAtom
HSIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- | Parse a Haskell string literal as defined by the Haskell 2010
-- language specification.
parseHaskellString :: Parser Text
parseHaskellString :: Parser Text
parseHaskellString = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall {u}. ParsecT Text u Identity (Maybe Char)
val forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity (Maybe Char)
esc))
  where val :: ParsecT Text u Identity (Maybe Char)
val = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\ Char
c -> Char
c forall a. Eq a => a -> a -> Bool
/= Char
'"' Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\\' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
> Char
'\026')
        esc :: ParsecT Text () Identity (Maybe Char)
esc = do Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
                 forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall {u}. ParsecT Text u Identity Char
gap forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'&') forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                   forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
code
        gap :: ParsecT Text u Identity Char
gap  = forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
        code :: ParsecT Text () Identity Char
code = forall {u}. ParsecT Text u Identity Char
eEsc forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity Char
eNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT Text u Identity Char
eCtrl forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u}. ParsecT Text u Identity Char
eAscii
        eCtrl :: ParsecT Text u Identity Char
eCtrl  = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'^' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall {a} {a}. (Enum a, Enum a) => a -> a
unCtrl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
upper
        eNum :: ParsecT Text () Identity Char
eNum   = (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                   (ParsecT Text () Identity Integer
decNumber forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'o' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity Integer
octNumber)
                              forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'x' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity Integer
hexNumber))
        eEsc :: ParsecT Text u Identity Char
eEsc   = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Char
b | (Char
a, Char
b) <- [(Char, Char)]
escMap ]
        eAscii :: ParsecT Text u Identity Char
eAscii = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Char
b)
                        | (String
a, Char
b) <- [(String, Char)]
asciiMap ]
        unCtrl :: a -> a
unCtrl a
c = forall a. Enum a => Int -> a
toEnum (forall a. Enum a => a -> Int
fromEnum a
c forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'A' forall a. Num a => a -> a -> a
+ Int
1)

escMap :: [(Char,  Char)]
escMap :: [(Char, Char)]
escMap = forall a b. [a] -> [b] -> [(a, b)]
zip String
"abfntv\\\"\'" String
"\a\b\f\n\r\t\v\\\"\'"

asciiMap :: [(String, Char)]
asciiMap :: [(String, Char)]
asciiMap = forall a b. [a] -> [b] -> [(a, b)]
zip
  [String
"BS",String
"HT",String
"LF",String
"VT",String
"FF",String
"CR",String
"SO",String
"SI",String
"EM"
  ,String
"FS",String
"GS",String
"RS",String
"US",String
"SP",String
"NUL",String
"SOH",String
"STX",String
"ETX"
  ,String
"EOT",String
"ENQ",String
"ACK",String
"BEL",String
"DLE",String
"DC1",String
"DC2",String
"DC3"
  ,String
"DC4",String
"NAK",String
"SYN",String
"ETB",String
"CAN",String
"SUB",String
"ESC",String
"DEL"]
  (String
"\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP\NUL\SOH" forall a. [a] -> [a] -> [a]
++
   String
"\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK" forall a. [a] -> [a] -> [a]
++
   String
"\SYN\ETB\CAN\SUB\ESC\DEL")

-- | Parse a Haskell floating-point number as defined by the Haskell
-- 2010 language specification.
parseHaskellFloat :: Parser Double
parseHaskellFloat :: Parser Double
parseHaskellFloat = do
  Integer
n <- ParsecT Text () Identity Integer
decNumber
  forall {a}. Integral a => a -> Parser Double
withDot Integer
n forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {a}. Integral a => a -> Parser Double
noDot Integer
n
  where withDot :: a -> Parser Double
withDot a
n = do
          Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
          Integer
m <- ParsecT Text () Identity Integer
decNumber
          Double
e <- forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option Double
1.0 Parser Double
expn
          forall (m :: * -> *) a. Monad m => a -> m a
return ((forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Num a => a -> a -> a
+ forall {a} {t}. (Integral a, Fractional t) => a -> t -> t
asDec Integer
m Double
0) forall a. Num a => a -> a -> a
* Double
e)
        noDot :: a -> Parser Double
noDot a
n = do
          Double
e <- Parser Double
expn
          forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Num a => a -> a -> a
* Double
e)
        expn :: Parser Double
expn = do
          Char
_ <- forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"eE"
          Double -> Double
s <- forall a. Num a => Parser (a -> a)
power
          Integer
x <- ParsecT Text () Identity Integer
decNumber
          forall (m :: * -> *) a. Monad m => a -> m a
return (Double
10 forall a. Floating a => a -> a -> a
** Double -> Double
s (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x))
        asDec :: a -> t -> t
asDec a
0 t
k = t
k
        asDec a
n t
k =
          a -> t -> t
asDec (a
n forall a. Integral a => a -> a -> a
`div` a
10) ((forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
n forall a. Integral a => a -> a -> a
`rem` a
10) forall a. Num a => a -> a -> a
+ t
k) forall a. Num a => a -> a -> a
* t
0.1)

power :: Num a => Parser (a -> a)
power :: forall a. Num a => Parser (a -> a)
power = forall a. Num a => a -> a
negate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-' forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall a. a -> a
id forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'+' forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id

-- | Parse a Haskell integer literal as defined by the Haskell 2010
-- language specification.
parseHaskellInt :: Parser Integer
parseHaskellInt :: ParsecT Text () Identity Integer
parseHaskellInt = do
  Integer -> Integer
s <- forall a. Num a => Parser (a -> a)
power
  Integer
n <- ParsecT Text () Identity Integer
pZeroNum forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity Integer
decNumber
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Integer
s Integer
n))

pZeroNum :: Parser Integer
pZeroNum :: ParsecT Text () Identity Integer
pZeroNum = forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'0' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
  (  (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"xX" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity Integer
hexNumber)
 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"oO" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Text () Identity Integer
octNumber)
 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT Text () Identity Integer
decNumber
 forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
  )

pHaskLikeAtom :: Parser HaskLikeAtom
pHaskLikeAtom :: Parser HaskLikeAtom
pHaskLikeAtom
   =  Double -> HaskLikeAtom
HSFloat   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Double
parseHaskellFloat forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"float")
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Integer -> HaskLikeAtom
HSInt     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT Text () Identity Integer
parseHaskellInt   forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"integer")
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Text -> HaskLikeAtom
HSString  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text
parseHaskellString    forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"string literal")
  forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Text -> HaskLikeAtom
HSIdent   forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text
parseR5RSIdent forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"token")

sHaskLikeAtom :: HaskLikeAtom -> Text
sHaskLikeAtom :: HaskLikeAtom -> Text
sHaskLikeAtom (HSIdent Text
t)  = Text
t
sHaskLikeAtom (HSString Text
s) = String -> Text
pack (forall a. Show a => a -> String
show Text
s)
sHaskLikeAtom (HSInt Integer
i)    = String -> Text
pack (forall a. Show a => a -> String
show Integer
i)
sHaskLikeAtom (HSFloat Double
f)  = String -> Text
pack (forall a. Show a => a -> String
show Double
f)

-- | This `SExprParser` understands s-expressions that contain
--   Scheme-like tokens, as well as string literals, integer
--   literals, and floating-point literals. Each of these values
--   is parsed according to the lexical rules in the Haskell
--   report, so the same set of string escapes, numeric bases,
--   and floating-point options are available. This spec does
--   not parse comments and does not understand any reader
--   macros.
--
-- >>> decode haskLikeParser "(0x01 \"\\x65lephant\")"
-- Right [SCons (SAtom (HSInt 1)) (SCons (SAtom (HSString "elephant")) SNil)]
haskLikeParser :: SExprParser HaskLikeAtom (SExpr HaskLikeAtom)
haskLikeParser :: SExprParser HaskLikeAtom (SExpr HaskLikeAtom)
haskLikeParser = forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser Parser HaskLikeAtom
pHaskLikeAtom

-- | A 'haskLikeParser' which produces 'Located' values
--
-- >>> decode locatedHaskLikeParser $ pack "(0x01 \"\\x65lephant\")"
-- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 6)) (HSInt 1))) (SCons (SAtom (At (Span (line 1, column 7) (line 1, column 20)) (HSString "elephant"))) SNil)]
--
-- >>> decode locatedHaskLikeParser $ pack "(1 elephant)"
-- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 3)) (HSInt 1))) (SCons (SAtom (At (Span (line 1, column 4) (line 1, column 12)) (HSIdent "elephant"))) SNil)]
locatedHaskLikeParser :: SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
locatedHaskLikeParser :: SExprParser (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
locatedHaskLikeParser = forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser (Located a)
located Parser HaskLikeAtom
pHaskLikeAtom

-- | This 'SExprPrinter' emits s-expressions that contain Scheme-like
--   tokens as well as string literals, integer literals, and floating-point
--   literals, which will be emitted as the literals produced by Haskell's
--   'show' function. This printer will produce a flat s-expression with
--   no indentation of any kind.
--
-- >>> encode haskLikePrinter [L [A (HSInt 1), A (HSString "elephant")]]
-- "(1 \"elephant\")"
haskLikePrinter :: SExprPrinter HaskLikeAtom (SExpr HaskLikeAtom)
haskLikePrinter :: SExprPrinter HaskLikeAtom (SExpr HaskLikeAtom)
haskLikePrinter = forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint HaskLikeAtom -> Text
sHaskLikeAtom

-- | Ignore location tags when packing values into text
sLocatedHasklikeAtom :: Located HaskLikeAtom -> Text
sLocatedHasklikeAtom :: Located HaskLikeAtom -> Text
sLocatedHasklikeAtom (At Location
_loc HaskLikeAtom
e) = HaskLikeAtom -> Text
sHaskLikeAtom HaskLikeAtom
e

-- | A 'SExprPrinter' for 'Located' values. Works exactly like 'haskLikePrinter'
--   It ignores the location tags when printing the result.
--
-- >>> let (Right dec) = decode locatedHaskLikeParser $ pack "(1 elephant)"
-- [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 3)) (HSInt 1))) (SCons (SAtom (At (Span (line 1, column 4) (line 1, column 12)) (HSIdent "elephant"))) SNil)]
--
-- >>> encode locatedHaskLikePrinter dec
-- "(1 elephant)"
locatedHaskLikePrinter :: SExprPrinter (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
locatedHaskLikePrinter :: SExprPrinter (Located HaskLikeAtom) (SExpr (Located HaskLikeAtom))
locatedHaskLikePrinter = forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint Located HaskLikeAtom -> Text
sLocatedHasklikeAtom