koneko-0.0.2: src/Koneko/Read.hs
-- -- ; {{{1
--
-- File : Koneko/Read.hs
-- Maintainer : Felix C. Stegerman <flx@obfusk.net>
-- Date : 2022-02-12
--
-- Copyright : Copyright (C) 2022 Felix C. Stegerman
-- Version : v0.0.1
-- License : GPLv3+
--
-- -- ; }}}1
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- {{{1
-- |
--
-- >>> :set -XOverloadedStrings
-- >>> x = read "nil #f 42 3.14 \"Hello, World!\" :foo foo"
-- >>> x
-- [nil,#f,42,3.14,"Hello, World!",:foo,foo]
-- >>> map D.typeOf x
-- [#<::nil>,#<::bool>,#<::int>,#<::float>,#<::str>,#<::kwd>,#<::ident>]
--
-- >>> x = read "( 1 2 :foo ) 'foo [ x . 'x 'x ]"
-- >>> x
-- [( 1 2 :foo ),'foo,[ x . 'x 'x ]]
-- >>> map D.typeOf x
-- [#<::list>,#<::quot>,#<::block>]
--
-- ... TODO ...
--
-- }}}1
module Koneko.Read (read, read') where
import Control.Exception (throw)
import Control.Monad (replicateM)
import Data.Functor
import Data.List (foldl')
import Data.Maybe (fromJust) -- careful!
import Data.Text (Text)
import Prelude hiding (quot, read)
import Text.Megaparsec
import Text.Megaparsec.Char
#if !MIN_VERSION_GLASGOW_HASKELL(8, 8, 1, 0)
import Control.Monad.Fail (MonadFail)
import Data.List (init)
#endif
import qualified Data.Char as C
import qualified Data.Text as T
import Koneko.Data (Identifier, Ident, Block(..), KValue(..))
import Koneko.Misc (Parser, pIdent, pIdent_, pInt, pFloat, lexeme,
symbol, sp)
import qualified Koneko.Data as D
-- TODO:
-- * parser labels
-- * test corner cases & failures
read :: Text -> [KValue]
read = read' "(read)"
read' :: FilePath -> Text -> [KValue]
read' f code = either (throw . D.ParseError . errorBundlePretty) id
$ parse program f code
-- parser: primitives --
nil, bool, int, float, str, kwd :: Parser KValue
bool = (D.false <$ string "#f") <|>
(D.true <$ string "#t")
nil = D.nil <$ string "nil"
int = D.int <$> pInt
float = D.float <$> pFloat
str = D.str <$> _str
kwd = D.kwd <$> (char ':' *> (_str <|> pIdent))
_str :: Parser Text
_str = char '"' >> T.concat <$> manyTill (choice [
esc, hex "\\x" 2, hex "\\u" 4, hex "\\U" 8, chr
]) (char '"')
where
esc = choice [ t <$ string f | (f,t) <- bsl ] <?> "escape sequence"
chr = T.singleton <$> anySingle <?> "character"
bsl = zip D.escapeFrom D.escapeTo
hex p n = string p >> T.singleton <$> _hex n
_hex :: Int -> Parser Char
_hex n = C.chr . foldl' (\a c -> a * 16 + C.digitToInt c) 0 <$>
replicateM n (satisfy C.isHexDigit <?> "hex digit")
-- TODO: rx
-- parser: values --
prim, list, ident, quot, block :: Parser KValue
prim = choice $ map (try . lexeme) [nil, int, float] ++
map lexeme [bool, str, kwd]
list = try $ D.list <$> (a <|> b)
where
a = [] <$ symbol "()"
b = symbol "(" *> manyValuesTill (symbol ")")
-- | NB: also matches float and int (but they match earlier)
ident = KIdent <$> ident_
quot = char '\'' >> KQuot <$> ident_
block = KBlock <$> block_
-- TODO
block_ :: Parser Block
block_ = try $ do
_ <- symbol "["
params <- concat <$> (optional $ try $ manyTill ident_ $ symbol ".")
code <- manyValuesTill $ symbol "]"
return $ Block params code Nothing
-- parser: sugar --
ellipsis, modid, qmodid, qhole, dhole, qdig, ddig, qdot, qbang, dot,
bang, dict, key, apply, applyDict, idblk :: Parser [KValue]
ellipsis = [_IDENT "ellipsis"] <$ symbol "..."
modid = try $ do
m <- D.kwd . D.unIdent <$> identNL <* char '.'
i <- D.kwd . D.unIdent <$> ident_
return [i, m, _IDENT "module-get", _IDENT "call"]
qmodid = try $ char '\'' >> init <$> modid -- safe!
-- TODO
qhole = try $ char '\'' >> _wrap <$> block_
dhole = try $ char '.' >> ((++ [_IDENT "call"]) . _wrap) <$> block_
qdig = try $ char '\'' >> _dig (KQuot . _IDENT') -- safe!
ddig = try $ char '.' >> _dig _IDENT -- safe!
qdot = string "'." >> _blk <$> _isc []
qbang = string "'!" >> _blk <$> _isc [_IDENT "call"]
dot = char '.' >> _isc []
bang = char '!' >> _isc [_IDENT "call"]
dict = try $ fmap ((:[_IDENT "dict"]) . D.list)
$ symbol "{" *> manyValuesTill (symbol "}")
key = try $ do
k <- sugarIdent ':'; v <- value_
return $ [D.kwd k] ++ v ++ [_IDENT "=>"]
apply = try $ do
(q, l) <- _ap '(' ")"; return [l, q, _IDENT "apply"]
applyDict = try $ do
(q, l) <- _ap '{' "}"
return [l, _IDENT "dict", q, _IDENT "apply-dict"]
idblk = try $ do i <- identNL; b <- block_; return [KBlock b, KIdent i]
_wrap :: Block -> [KValue]
_wrap b = [D.block (D.digitParams b) [KBlock b] Nothing]
_dig :: (Text -> KValue) -> Parser [KValue]
_dig f = fmap ((:[]) . f . T.singleton)
$ lexeme $ satisfy (`elem` ['1'..'9'])
_blk :: [KValue] -> [KValue]
_blk code = [D.block [] code Nothing]
_isc :: [KValue] -> Parser [KValue]
_isc vs = f <$> ident_
where
f i = [D.kwd $ D.unIdent i, _IDENT "swap", _IDENT "call"] ++ vs
_ap :: Char -> Text -> Parser (KValue, KValue)
_ap op cl = do
i <- sugarIdent op; vs <- manyValuesTill $ symbol cl
q <- KQuot <$> identOrFail i
return (q, D.list vs)
sugar :: Parser [KValue]
sugar = choice [
ellipsis, modid, qmodid, qhole, dhole, qdig, ddig, qdot, qbang,
dot, bang, dict, key, apply, applyDict, idblk
]
-- parser: multiple values & program --
-- | NB: match ident last
oneValue :: Parser KValue
oneValue = choice [prim, list, quot, block, ident]
value_, manyValues, program :: Parser [KValue]
value_ = sugar <|> (:[]) <$> oneValue
manyValues = concat <$> many value_
program = optional shebang *> sp *> manyValues <* eof
manyValuesTill :: Parser a -> Parser [KValue]
manyValuesTill end = concat <$> manyTill value_ end
shebang :: Parser ()
shebang = void $ string "#!" >> many (satisfy (/= '\n')) >> newline
-- parser: miscellaneous --
ident_, identNL :: Parser Ident
ident_ = lexeme $ identNL
identNL = pIdent >>= identOrFail
-- TODO
sugarIdent :: Char -> Parser Identifier
sugarIdent c = try $ do
i <- lexeme $ pIdent_ $ Just c
if T.last i /= c then fail "TODO" else return $ T.init i -- safe!
-- miscellaneous --
-- UNSAFE!
_IDENT :: Text -> KValue
_IDENT' :: Text -> Ident
_IDENT = KIdent . _IDENT'
_IDENT' = fromJust . D.ident . D.underscored
identOrFail :: MonadFail m => Identifier -> m Ident
identOrFail = maybe (fail "invalid ident") return . D.ident
-- vim: set tw=70 sw=2 sts=2 et fdm=marker :