diff --git a/Data/AttoLisp.hs b/Data/AttoLisp.hs --- a/Data/AttoLisp.hs +++ b/Data/AttoLisp.hs @@ -34,7 +34,7 @@ import Control.Applicative import Control.DeepSeq (NFData(..)) import Control.Monad -import Data.Attoparsec.Char8 hiding ( Parser, Result, parse, string, double ) +import Data.Attoparsec.Char8 hiding ( Parser, Result, parse, string, double, number ) import Data.Data import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.List ( foldl' ) @@ -44,6 +44,7 @@ import Data.Word ( Word, Word8, Word16, Word32, Word64 ) import Numeric (showHex) import qualified Data.Attoparsec as A +import qualified Data.Attoparsec.Char8 as AC import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Unsafe as B @@ -648,22 +649,87 @@ quoted l = List [Symbol "quote", l] -- | Parse a symbol or a number. Symbols are expected to be utf8. --- --- TODO: support escapes in symbols atom :: A.Parser Lisp -atom = do - sym <- takeWhile1 (\c -> not (terminatingChar c)) - -- If it looks like a number it is parsed as a number. - let !w = B.unsafeIndex sym 0 - if (w >= 48 && w <= 57) || -- digit - w == 43 || w == 45 -- '+' or '-' - then do - case A.parseOnly number sym of - Left _ -> pure (Symbol (T.decodeUtf8 sym)) - Right n -> pure (Number n) - else - pure (Symbol (T.decodeUtf8 sym)) - +atom = number <|> symbol + +number :: A.Parser Lisp +number = do + sym <- takeWhile1 (not . terminatingChar) + case A.parseOnly AC.number sym of + Left _ -> fail "Not a number" + Right n -> return (Number n) + +symbol :: A.Parser Lisp +symbol = Symbol <$> sym + where + sym = suffix + <|> do { p1 <- part; option p1 (T.append p1 <$> suffix) } + suffix = T.append <$> psep <*> part + psep = do + c <- char ':' + c2 <- option [] (pure <$> char ':') + pure $ T.pack (c:c2) + part = multiEscPart <|> basicPart + +-- | Parse a multi-escaped symbol part (the part could either be the +-- package name or the symbol itself), that is, anything between unescaped +-- vertical bars, e.g. +-- +-- * |foo| +-- +-- * |foo ) bar| +-- +-- * |foo \| bar| +-- +-- We return the whole thing unadulterated, vertical bars and all. +-- Symbols are expected to be utf8. +multiEscPart :: A.Parser T.Text +multiEscPart = do + vb <- char8 '|' + (T.decodeUtf8 . B.cons vb) <$> chunk + where + stop c = c == backslash || c == verticalBar + chunk = do + p1 <- A.takeWhile (not . stop) + p2 <- Data.Attoparsec.Char8.take 1 + case p2 of + "|" -> return (p1 `B.append` p2) + "\\" -> do { p3 <- Data.Attoparsec.Char8.take 1 + ; B.append (p1 `B.append` p2 `B.append` p3) <$> chunk + } + _ -> error "Data.AttoLisp: should be impossible to have gotten something other than '\\' or | here" + +-- | Parse a non-multi-escaped symbol part (the part could either be the +-- package name or the symbol itself) +-- Symbols are expected to be utf8. +basicPart :: A.Parser T.Text +basicPart = do + sym <- takeWhile1 (not . stop) + let !lst = B.last sym + if isSingleEsc lst + then -- single-escaped symbol: read more stuff + (decodeSym . B.append sym) <$> chunk + else -- other cases, eg. foo, |bar| + pure (decodeSym sym) + where + stop c = terminatingChar c || c == '|' || c == ':' + isSingleEsc w = w == backslash + -- parts of an atom that follow a single escape + -- so given something like x\yz, this handles the + -- parsing of yz + chunk = do + escapee <- A.take 1 + done <- atEnd + if done then pure escapee else do + rest <- takeWhile1 (not . terminatingChar) + let !lst = B.last rest + !pref = escapee `B.append` rest + if lst == backslash + then B.append pref <$> chunk + else pure pref + -- + decodeSym = T.decodeUtf8 + terminatingChar :: Char -> Bool terminatingChar c = c == ',' || c == '(' || c == ')' || c == '\'' || c == ';' || c == '`' || isSpace c @@ -682,12 +748,17 @@ backslash = 92 {-# INLINE backslash #-} +verticalBar :: Word8 +verticalBar = 124 +{-# INLINE verticalBar #-} + skipLispSpace :: A.Parser () -skipLispSpace = skipSpace >> optional comment >> skipSpace +skipLispSpace = + skipSpace >> many (comment >> skipSpace) >> return () comment :: A.Parser () comment = do - _ <- char ';' >> Control.Applicative.many (notChar '\n') + _ <- char ';' >> many (notChar '\n') end <- atEnd if end then char '\n' >> return () else return () diff --git a/atto-lisp.cabal b/atto-lisp.cabal --- a/atto-lisp.cabal +++ b/atto-lisp.cabal @@ -1,5 +1,5 @@ name: atto-lisp -version: 0.2.1.1 +version: 0.2.1.2 license: BSD3 license-file: LICENSE author: Thomas Schilling @@ -11,7 +11,7 @@ category: Text, Data stability: provisional build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.10 library build-depends: @@ -19,8 +19,8 @@ base >= 4.2 && < 5, blaze-builder >= 0.3 && < 0.4, blaze-textual >= 0.1 && < 0.3, - bytestring >= 0.9 && < 0.10, - containers >= 0.3 && < 0.5, + bytestring >= 0.9 && < 0.11, + containers >= 0.3 && < 0.6, deepseq >= 1.1 && < 1.4, text >= 0.10 && < 0.12 @@ -28,3 +28,18 @@ Data.AttoLisp ghc-options: -Wall + default-language: Haskell2010 + +Test-Suite test + Type: exitcode-stdio-1.0 + Main-is: test-attolisp.hs + Hs-Source-Dirs: test + Build-depends: atto-lisp + , attoparsec + , base + , bytestring + , text + , HUnit + , test-framework + , test-framework-hunit + Default-language: Haskell2010 diff --git a/test/test-attolisp.hs b/test/test-attolisp.hs new file mode 100644 --- /dev/null +++ b/test/test-attolisp.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings, Rank2Types, DeriveDataTypeable, BangPatterns, + MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, + UndecidableInstances #-} + +module Main where + +import Control.Applicative +import Data.AttoLisp +import qualified Data.Attoparsec as A +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Test.HUnit +import Test.Framework.Providers.HUnit +import Test.Framework + +data Msg = Msg T.Text Integer + deriving (Eq, Show) + +instance ToLisp Msg where + toLisp (Msg t n) = mkStruct "msg" [toLisp t, toLisp n] + +instance FromLisp Msg where + parseLisp e = struct "msg" Msg e + + +test_sexp1 = + show (List [Number 42.2, Symbol "foo", "blah"]) == "(42.2 foo \"blah\")" + +test_msg1 = toLisp (Msg "foo" 42) +test_msg2 = List [Symbol "msg"] +test_msg3 = List [Symbol "msg", "bar", "baz"] + +data T = T { tin :: B.ByteString + , tout :: Maybe Lisp + } + +main :: IO () +main = defaultMain + [ testSimple + , testTokens + ] + +tcase :: T -> Test.Framework.Test +tcase (T inp out) = testCase inpStr $ assertParse inpStr out out2 + where + inpStr = BC.unpack inp + out2 = A.parseOnly (lisp <* A.endOfInput) inp + +assertParse _ Nothing (Left _) = return () +assertParse _ Nothing (Right v2) = assertFailure $ "expected parse error\n but got: " ++ show v2 +assertParse _ (Just v) (Left e) = assertFailure $ "expected succesful parse: " ++ show v ++ "\n but got error: " ++ e +assertParse desc (Just v) (Right v2) = assertEqual desc v v2 + +testSimple = testGroup "simple" $ map tcase + [ T "()" (Just $ List []) + , T "42" (Just $ Number 42) + , T ";;foo\n42" (Just $ Number 42) + , T ";;foo\n;;bar\n42" (Just $ Number 42) + , T "(4 5 6)" (Just $ List [Number 4, Number 5, Number 6]) + , T "(4 5 6 )" (Just $ List [Number 4, Number 5, Number 6]) + , T "(3 (4))" (Just $ List [Number 3, List [Number 4]]) + , T "'(3 4)" (Just $ List [Symbol "quote", List [Number 3, Number 4]]) + , T "\"a; however, b\"" (Just $ String "a; however, b") + , T "(x ;comment\ny)" (Just $ List [Symbol "x", Symbol "y"]) , T "\"foo\"" (Just (String "foo")) + , T "foo" (Just (Symbol "foo")) + , T "(foo \"bar\" 23)" (Just $ List [Symbol "foo", String "bar", Number 23]) + -- this will have to do for now; no proper support/representation for escapes + -- so the idea is that we try to return it completely unprocessed + ] + +testTokens = testGroup "tokens" + [ testGroup "bare" $ map tcase symbols + , testGroup "KEYWORD" $ map (tcase . addPkg "" ) symbols + , testGroup "intern" $ map (tcase . addPkg "foo") symbols + , testGroup "extern" $ map (tcase . addPkg "foo:") symbols + , testGroup "intern-esc" $ map (tcase . addPkg "|foo|") symbols + -- TODO: what's the right behaviour when we have package prefixes here? + , tcase $ T "+1" (Just (Number 1)) -- This is the integer 1, not a symbol. + ] + +symbols = + [ T "xyz\\," (Just (Symbol "xyz\\,")) -- ideally, something more like 'xyz', + , T "\\n" (Just (Symbol "\\n")) -- NB: actually backslash-n, not newline! + -- ideally, something more like 'n', + , T "|foO|" (Just (Symbol "|foO|")) -- ideally, something more like 'foO' + , T "|f,o|" (Just (Symbol "|f,o|")) -- ideally, something more like 'f,o' + , T "|f\\|x|" (Just (Symbol "|f\\|x|")) -- ideally, something more like 'f|x' + , T "|f\\|" Nothing + -- From the HyperSpec + -- Note that instead of interpreting case, we aim here to preserve all the + -- characters in the token (including the escapes) + -- http://www.lispworks.com/documentation/HyperSpec/Body/02_cd.htm + , T "FROBBOZ" (Just (Symbol "FROBBOZ")) -- The symbol whose name is FROBBOZ. + , T "frobboz" (Just (Symbol "frobboz")) -- Another way to notate the same symbol. + , T "fRObBoz" (Just (Symbol "fRObBoz")) -- Yet another way to notate it. + , T "unwind-protect" (Just (Symbol "unwind-protect")) -- A symbol with a hyphen in its name. + , T "+$" (Just (Symbol "+$")) -- The symbol named +$. + -- TODO: :-(; tricky! + -- , T "1+" (Just (Symbol "1+")) -- The symbol named 1+. + , T "pascal_style" (Just (Symbol "pascal_style")) -- This symbol has an underscore in its name. + , T "file.rel.43" (Just (Symbol "file.rel.43")) -- This symbol has periods in its name. + , T "\\(" (Just (Symbol "\\(")) -- The symbol whose name is (. + , T "\\+1" (Just (Symbol "\\+1")) -- The symbol whose name is +1. + , T "+\\1" (Just (Symbol "+\\1")) -- Also the symbol whose name is +1. + , T "\\frobboz" (Just (Symbol "\\frobboz")) -- The symbol whose name is fROBBOZ. + -- TODO: :-( tricky! + -- , T "3.14159265\\s0" (Just (Symbol "3.14159265\\s0")) -- The symbol whose name is 3.14159265s0. + -- , T "3.14159265\\S0" (Just (Symbol "3.14159265\\S0")) -- A different symbol, whose name is 3.14159265S0. + -- , T "3.14159265s0" (Just (Symbol "3.14159265s0")) -- A possible short float approximation to . + , T "APL\\\\360" (Just (Symbol "APL\\\\360")) -- The symbol whose name is APL\360. + , T "apl\\\\360" (Just (Symbol "apl\\\\360")) -- Also the symbol whose name is APL\360. + , T "\\(b^2\\)\\-\\4*a*c" (Just (Symbol "\\(b^2\\)\\-\\4*a*c")) -- The name is (B^2) - 4*A*C. + -- Parentheses and two spaces in it. + , T "\\(\\b^2\\)\\-\\4*\\a*\\c" (Just (Symbol "\\(\\b^2\\)\\-\\4*\\a*\\c")) -- The name is (b^2) - 4*a*c. + -- Letters explicitly lowercase. + , T "|\"|" (Just (Symbol "|\"|")) -- The same as writing \". + , T "|(b^2) - 4*a*c|" (Just (Symbol "|(b^2) - 4*a*c|")) -- The name is (b^2) - 4*a*c. + , T "|frobboz|" (Just (Symbol "|frobboz|")) -- The name is frobboz, not FROBBOZ. + , T "|APL\\360|" (Just (Symbol "|APL\\360|")) -- The name is APL360. + , T "|APL\\\\360|" (Just (Symbol "|APL\\\\360|")) -- The name is APL\360. + , T "|apl\\\\360|" (Just (Symbol "|apl\\\\360|")) -- The name is apl\360. + , T "|\\|\\||" (Just (Symbol "|\\|\\||")) -- Same as \|\| ---the name is ||. + , T "|(B^2) - 4*A*C|" (Just (Symbol "|(B^2) - 4*A*C|")) -- The name is (B^2) - 4*A*C. + -- Parentheses and two spaces in it. + , T "|(b^2) - 4*a*c|" (Just (Symbol "|(b^2) - 4*a*c|")) -- The name is (b^2) - 4*a*c. + ] + +addPkg p t = t { tin = BC.concat [ p, ":", tin t ] + , tout = tweak (tout t) + } + where + tweak Nothing = Nothing + tweak (Just (Symbol x)) = Just . Symbol $ T.concat [T.decodeUtf8 p, ":", x] + tweak (Just x) = Nothing