{-# LANGUAGE OverloadedStrings #-}

module Data.SCargot.Language.Basic
  ( -- * Spec
    -- $descr
    basicParser
  , basicPrinter
  , locatedBasicParser
  , locatedBasicPrinter
  ) where

import           Control.Applicative ((<$>))
import           Data.Char (isAlphaNum)
import           Text.Parsec (many1, satisfy)
import           Data.Text (Text, pack)
import           Data.Functor.Identity (Identity)
import           Text.Parsec.Prim (ParsecT)

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

isAtomChar :: Char -> Bool
isAtomChar :: Char -> Bool
isAtomChar Char
c = Char -> Bool
isAlphaNum Char
c
  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>'
  Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'!' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'?'

pToken :: ParsecT Text a Identity Text
pToken :: forall a. ParsecT Text a Identity Text
pToken = String -> Text
pack (String -> Text)
-> ParsecT Text a Identity String -> ParsecT Text a Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text a Identity Char -> ParsecT Text a Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT Text a Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isAtomChar)

-- $descr
-- The 'basicSpec' describes S-expressions whose atoms are simply
-- text strings that contain alphanumeric characters and a small
-- set of punctuation. It does no parsing of numbers or other data
-- types, and will accept tokens that typical Lisp implementations
-- would find nonsensical (like @77foo@).
--
-- Atoms recognized by the 'basicSpec' are any string matching the
-- regular expression @[A-Za-z0-9+*<>/=!?-]+@.

-- | A 'SExprParser' that understands atoms to be sequences of
--   alphanumeric characters as well as the punctuation
--   characters @[-*/+<>=!?]@, and does no processing of them.
--
-- >>> decode basicParser "(1 elephant)"
-- Right [SCons (SAtom "1") (SCons (SAtom "elephant") SNil)]
basicParser :: SExprParser Text (SExpr Text)
basicParser :: SExprParser Text (SExpr Text)
basicParser = Parser Text -> SExprParser Text (SExpr Text)
forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser Parser Text
forall a. ParsecT Text a Identity Text
pToken

-- | A 'basicParser' which produces 'Located' values
--
-- >>> decode locatedBasicParser $ pack "(1 elephant)"
-- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 3)) "1")) (SCons (SAtom (At (Span (line 1, column 4) (line 1, column 12)) "elephant")) SNil)]
--
-- >>> decode locatedBasicParser $ pack "(let ((x 1))\n  x)"
-- Right [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 5)) "let")) (SCons (SCons (SCons (SAtom (At (Span (line 1, column 8) (line 1, column 9)) "x")) (SCons (SAtom (At (Span (line 1, column 10) (line 1, column 11)) "1")) SNil)) SNil) (SCons (SAtom (At (Span (line 2, column 3) (line 2, column 4)) "x")) SNil))]
locatedBasicParser :: SExprParser (Located Text) (SExpr (Located Text))
locatedBasicParser :: SExprParser (Located Text) (SExpr (Located Text))
locatedBasicParser = Parser (Located Text)
-> SExprParser (Located Text) (SExpr (Located Text))
forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser (Parser (Located Text)
 -> SExprParser (Located Text) (SExpr (Located Text)))
-> Parser (Located Text)
-> SExprParser (Located Text) (SExpr (Located Text))
forall a b. (a -> b) -> a -> b
$ Parser Text -> Parser (Located Text)
forall a. Parser a -> Parser (Located a)
located Parser Text
forall a. ParsecT Text a Identity Text
pToken

-- | A 'SExprPrinter' that prints textual atoms directly (without quoting
--   or any other processing) onto a single line.
--
-- >>> encode basicPrinter [L [A "1", A "elephant"]]
-- "(1 elephant)"
basicPrinter :: SExprPrinter Text (SExpr Text)
basicPrinter :: SExprPrinter Text (SExpr Text)
basicPrinter = (Text -> Text) -> SExprPrinter Text (SExpr Text)
forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint Text -> Text
forall a. a -> a
id

-- | A 'SExprPrinter' for 'Located' values. Works exactly like 'basicPrinter'
--   It ignores the location tags when printing the result.
--
-- >>> let (Right dec) = decode locatedBasicParser $ pack "(1 elephant)"
-- [SCons (SAtom (At (Span (line 1, column 2) (line 1, column 3)) "1")) (SCons (SAtom (At (Span (line 1, column 4) (line 1, column 12)) "elephant")) SNil)]
--
-- >>> encode locatedBasicPrinter dec
-- "(1 elephant)"
locatedBasicPrinter :: SExprPrinter (Located Text) (SExpr (Located Text))
locatedBasicPrinter :: SExprPrinter (Located Text) (SExpr (Located Text))
locatedBasicPrinter = (Located Text -> Text)
-> SExprPrinter (Located Text) (SExpr (Located Text))
forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint Located Text -> Text
forall {a}. Located a -> a
unLoc
  where unLoc :: Located a -> a
unLoc (At Location
_loc a
e) = a
e