content: {-# 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.SCargot (SExprParser, SExprPrinter, flatPrint, mkParser)
  import Data.SCargot.Common
  import Data.SCargot.Repr.Basic (SExpr)
  import Data.String (IsString (..))
  import Data.Text (Text, pack)
  import Text.Parsec
  import Text.Parsec.Text (Parser)
  import Prelude hiding (concatMap)
  
  -- $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
    = -- | An identifier, parsed according to the R5RS Scheme
      --   standard
      HSIdent Text
    | -- | A string, parsed according to the syntax for string
      --   literals in the Haskell report
      HSString Text
    | -- | An arbitrary-sized integer value, parsed according to
      --   the syntax for integer literals in the Haskell report
      HSInt Integer
    | -- | A double-precision floating-point value, parsed
      --   according to the syntax for floats in the Haskell
      --   report
      HSFloat Double
    deriving (Eq, Show)
  
  instance IsString HaskLikeAtom where
    fromString = HSIdent . fromString
  
  instance IsString (Located HaskLikeAtom) where
    fromString = (At dLocation) . HSIdent . fromString
  
  -- | Parse a Haskell string literal as defined by the Haskell 2010
  -- language specification.
  parseHaskellString :: Parser Text
  parseHaskellString = pack . catMaybes <$> between (char '"') (char '"') (many (val <|> esc))
    where
      val = Just <$> satisfy (\c -> c /= '"' && c /= '\\' && c > '\026')
      esc = do
        _ <- char '\\'
        Nothing <$ (gap <|> char '&')
          <|> Just <$> code
      gap = many1 space >> char '\\'
      code = eEsc <|> eNum <|> eCtrl <|> eAscii
      eCtrl = char '^' >> unCtrl <$> upper
      eNum =
        (toEnum . fromInteger)
          <$> ( decNumber <|> (char 'o' >> octNumber)
                  <|> (char 'x' >> hexNumber)
              )
      eEsc = choice [char a >> return b | (a, b) <- escMap]
      eAscii =
        choice
          [ try (string a >> return b)
            | (a, b) <- asciiMap
          ]
      unCtrl c = toEnum (fromEnum c - fromEnum 'A' + 1)
  
  escMap :: [(Char, Char)]
  escMap = zip "abfntv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"
  
  asciiMap :: [(String, Char)]
  asciiMap =
    zip
      [ "BS",
        "HT",
        "LF",
        "VT",
        "FF",
        "CR",
        "SO",
        "SI",
        "EM",
        "FS",
        "GS",
        "RS",
        "US",
        "SP",
        "NUL",
        "SOH",
        "STX",
        "ETX",
        "EOT",
        "ENQ",
        "ACK",
        "BEL",
        "DLE",
        "DC1",
        "DC2",
        "DC3",
        "DC4",
        "NAK",
        "SYN",
        "ETB",
        "CAN",
        "SUB",
        "ESC",
        "DEL"
      ]
      ( "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP\NUL\SOH"
          ++ "\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK"
          ++ "\SYN\ETB\CAN\SUB\ESC\DEL"
      )
  
  -- | Parse a Haskell floating-point number as defined by the Haskell
  -- 2010 language specification.
  parseHaskellFloat :: Parser Double
  parseHaskellFloat = do
    n <- decNumber
    withDot n <|> noDot n
    where
      withDot n = do
        _ <- char '.'
        m <- decNumber
        e <- option 1.0 expn
        return ((fromIntegral n + asDec m 0) * e)
      noDot n = do
        e <- expn
        return (fromIntegral n * e)
      expn = do
        _ <- oneOf "eE"
        s <- power
        x <- decNumber
        return (10 ** s (fromIntegral x))
      asDec 0 k = k
      asDec n k =
        asDec (n `div` 10) ((fromIntegral (n `rem` 10) + k) * 0.1)
  
  power :: Num a => Parser (a -> a)
  power = negate <$ char '-' <|> id <$ char '+' <|> return id
  
  -- | Parse a Haskell integer literal as defined by the Haskell 2010
  -- language specification.
  parseHaskellInt :: Parser Integer
  parseHaskellInt = do
    s <- power
    n <- pZeroNum <|> decNumber
    return (fromIntegral (s n))
  
  pZeroNum :: Parser Integer
  pZeroNum =
    char '0'
      >> ( (oneOf "xX" >> hexNumber)
             <|> (oneOf "oO" >> octNumber)
             <|> decNumber
             <|> return 0
         )
  
  pHaskLikeAtom :: Parser HaskLikeAtom
  pHaskLikeAtom =
    HSFloat <$> (try parseHaskellFloat <?> "float")
      <|> HSInt <$> (try parseHaskellInt <?> "integer")
      <|> HSString <$> (parseHaskellString <?> "string literal")
      <|> HSIdent <$> (parseR5RSIdent <?> "token")
  
  sHaskLikeAtom :: HaskLikeAtom -> Text
  sHaskLikeAtom (HSIdent t) = t
  sHaskLikeAtom (HSString s) = pack (show s)
  sHaskLikeAtom (HSInt i) = pack (show i)
  sHaskLikeAtom (HSFloat f) = pack (show 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 = mkParser 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 = mkParser $ located 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 = flatPrint sHaskLikeAtom
  
  -- | Ignore location tags when packing values into text
  sLocatedHasklikeAtom :: Located HaskLikeAtom -> Text
  sLocatedHasklikeAtom (At _loc e) = sHaskLikeAtom 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 = flatPrint sLocatedHasklikeAtom
  