gyehoek-hs/src/Gyehoek/Sexp/Read.hs

module Gyehoek.Sexp.Read
  ( readFile
  , readString
  , readString1
  , SourcePos(..)
  , readStringWithPos
  , readStringWithPos1
  ) where

import Text.Megaparsec
import Text.Megaparsec.Char hiding (string)
import qualified Text.Megaparsec.Char.Lexer as L
import Data.Void (Void)
import Gyehoek.Sexp.Syntax
import Gyehoek.Prelude hiding (Simple, (:<))
import qualified Data.Text.IO as T
import Prelude hiding (readFile)
import Data.Functor (($>))
import qualified Data.Text as T
import Data.Char (GeneralCategory(..), generalCategory)
import Data.Scientific (Scientific)
import Gyehoek.Jalmot


readFile :: (Jalmot :> es, IOE :> es) => FilePath -> Eff es (List Datum)
readFile f = do
  s <- liftIO . T.readFile $ f
  case runParser file f s of
    Right x -> pure x
    Left eb -> throwError . ReaderError $ eb

readString :: Jalmot :> es => Text -> Eff es (List Datum)
readString s = 
  case runParser file "<none>" s of
    Right x -> pure x
    Left eb -> throwError . ReaderError $ eb

readString1 :: Jalmot :> es => Text -> Eff es Datum
readString1 s = 
  case runParser file1 "<none>" s of
    Right x -> pure x
    Left eb -> throwError . ReaderError $ eb

initialStateFromSourcePos :: SourcePos -> s -> State s e
initialStateFromSourcePos pos s = State
  { stateInput = s
  , stateOffset = 0
  , stateParseErrors = []
  , statePosState = PosState
    { pstateInput = s
    , pstateOffset = 0
    , pstateSourcePos = pos
    , pstateTabWidth = defaultTabWidth
    , pstateLinePrefix = ""
    }
  }

readStringWithPos1
  :: Jalmot :> es
  => SourcePos
  -> Text
  -> Eff es Datum
readStringWithPos1 pos s =
  case snd $ runParser' file1 st of
    Right x -> pure x
    Left eb -> throwError . ReaderError $ eb
  where
    st = initialStateFromSourcePos pos s

readStringWithPos
  :: Jalmot :> es
  => SourcePos
  -> Text
  -> Eff es (List Datum)
readStringWithPos pos s =
  case snd $ runParser' file st of
    Right x -> pure x
    Left eb -> throwError . ReaderError $ eb
  where
    st = initialStateFromSourcePos pos s

type P = Parsec Void Text


--- lexer helpers

-- TODO: check R⁷RS's definition of ⟨atmosphere⟩.
-- TODO: datum comments.
-- | whitespace consumer.
sc :: P ()
sc = L.space space1
  (L.skipLineComment ";")
  (L.skipBlockCommentNested "#|" "|#")

lexeme :: P a -> P a
lexeme = L.lexeme sc

-- | verbatim text.
verb :: Text -> P Text
verb = L.symbol sc


--- tokens

identifier :: P Text
identifier = label "identifier" . lexeme . choice $
  [ typical-- , delimited, peculiar
  ]
  where
    typical = T.cons <$> initial <*> subsequent
      where
        subsequent = takeWhileP Nothing \c ->
          isInitial c ||
          c `hasCategory` [SpacingCombiningMark, EnclosingMark, DecimalNumber]
          || c == '.' || c == '@' || c == '+' || c == '-'
        initial = satisfy isInitial
    delimited = _
    peculiar = _

    hasCategory c xs = generalCategory c `elem` xs
    isInitial c = (c `hasCategory`
      [ UppercaseLetter, LowercaseLetter, TitlecaseLetter, ModifierLetter
      , OtherLetter
      -- , SpacingCombiningMark, EnclosingMark, DecimalNumber
      , LetterNumber, OtherNumber, DashPunctuation, ConnectorPunctuation
      , CurrencySymbol, OtherPunctuation, MathSymbol
      , ModifierSymbol, OtherSymbol, PrivateUse ]
      || c == '\x200c' || c == '\x200d')
      && c /= ';' && c /= '|' && c /= '"' && c /= '.'
      && c /= ',' && c /= '#'

boolean :: P Bool
boolean = label "boolean" . lexeme $ choice
  [ ("#true" <|> "#t") $> True
  , ("#false" <|> "#f") $> False
  ]

symbol = identifier

number :: P Scientific
number = label "number" . lexeme $ num
  where
    num = L.signed (pure ()) L.decimal
    -- prefix r = _
    -- radix = \case
    --   2 -> "#b"
    --   8 -> "#o"
    --   10 -> "" <|> "#d"
    --   16 -> "#x"

lparen = lexeme $ char '('
rparen = lexeme $ char ')'
dot = lexeme $ char '.'
verticalLine = lexeme $ char '|'

-- delimiter :: P ()
-- delimiter = choice
--   [ sc
--   , void verticalLine
--   , void lparen
--   , void rparen
--   , void (char '"')
--   , void (char ';')
--   ]

string :: P Text
string = label "string" . lexeme $
  char '"' *> (T.pack <$> many element) <* char '"'
  where
    element = choice
      [ satisfy (\c -> c /= '"' && c /= '\\')
      , "\\\"" $> '"'
      , "\\\\" $> '\\'
      ]

metaSplice :: P Text
metaSplice = label "splicing meta" . lexeme . between "##{" "}" $
  takeWhile1P Nothing (/= '}')

meta :: P Text
meta = label "meta" . lexeme . between "#{" "}" $
  takeWhile1P Nothing (/= '}')



file :: P (List Datum)
file = sc *> many datum <* eof

file1 :: P Datum
file1 = sc *> datum <* eof

datum :: P Datum
datum = do
  pos <- getSourcePos
  (position ?~ pos) <$> choice
    [ Compound <$> compoundDatum
    , Simple <$> simpleDatum
    -- , labeled
    -- , labelRef
    , MetaSplice <$> metaSplice
    , Meta <$> meta
    ]

simpleDatum :: P Simple
simpleDatum = choice
  [ SimpleBoolean <$> boolean
  , SimpleNumber <$> try number
  -- , SimpleCharacter <$> character
  , SimpleString <$> string
  , SimpleSymbol <$> symbol
  -- , SimpleBytevector <$> bytevector
  ]

compoundDatum :: P Compound
compoundDatum = choice
  [ list
  ]

list :: P Compound
list = label "list" . between lparen rparen $ do
  optional datum >>= \case
    Nothing -> pure $ ListF Ordinary []
    Just x -> do
      xs <- many datum
      optional (dot *> datum) >>= \case
        Nothing -> pure $ ListF Ordinary (x:xs)
        Just y -> pure $ DotListF (x:|xs) y