{-# 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 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. 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. 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. 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. Eq a => a -> a -> Bool
== Char
'?'

pToken :: ParsecT Text a Identity Text
pToken :: forall a. ParsecT Text a Identity Text
pToken = String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 =>
(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 = forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser 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 = forall atom. Parser atom -> SExprParser atom (SExpr atom)
mkParser forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Parser (Located a)
located 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 = forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint 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 = forall atom. (atom -> Text) -> SExprPrinter atom (SExpr atom)
flatPrint forall {a}. Located a -> a
unLoc
  where unLoc :: Located a -> a
unLoc (At Location
_loc a
e) = a
e