diff --git a/Data/SCargot/Comments.hs b/Data/SCargot/Comments.hs --- a/Data/SCargot/Comments.hs +++ b/Data/SCargot/Comments.hs @@ -11,6 +11,9 @@ -- ** Scripting Language Syntax -- $script , withOctothorpeComments + -- ** Prolog- or Matlab-Style Syntax + , withPercentComments + , withPercentBlockComments -- ** C-Style Syntax -- $clike , withCLikeLineComments @@ -112,6 +115,15 @@ -- @#@ and last until the end of the line. withOctothorpeComments :: SExprParser t a -> SExprParser t a withOctothorpeComments = setComment (lineComment "#") + +-- | MATLAB, Prolog, PostScript, and others use comments which begin +-- with @%@ and last until the end of the line. +withPercentComments :: SExprParser t a -> SExprParser t a +withPercentComments = setComment (lineComment "%") + +-- | MATLAB block comments are started with @%{@ and end with @%}@. +withPercentBlockComments :: SExprParser t a -> SExprParser t a +withPercentBlockComments = setComment (simpleBlockComment "%{" "%}") {- $intro diff --git a/Data/SCargot/Common.hs b/Data/SCargot/Common.hs --- a/Data/SCargot/Common.hs +++ b/Data/SCargot/Common.hs @@ -1,8 +1,13 @@ module Data.SCargot.Common ( -- $intro - -- * Lisp Identifier Syntaxes + -- * Identifier Syntaxes parseR5RSIdent , parseR6RSIdent , parseR7RSIdent + , parseXIDIdentStrict + , parseXIDIdentGeneral + , parseHaskellIdent + , parseHaskellVariable + , parseHaskellConstructor -- * Numeric Literal Parsers , signed , prefixedNumber @@ -115,6 +120,93 @@ signSub = initial <|> expSign <|> char '@' cons2 a b cs = a : b : cs cons3 a b c ds = a : b : c : ds + +-- | Parse a Haskell variable identifier: a sequence of alphanumeric +-- characters, underscores, or single quote that begins with a +-- lower-case letter. +parseHaskellVariable :: Parser Text +parseHaskellVariable = + T.pack <$> ((:) <$> small <*> many (small <|> + large <|> + digit' <|> + char '\'' <|> + char '_')) + where small = satisfy isLower + large = satisfy isUpper + digit' = satisfy isDigit + +-- | Parse a Haskell constructor: a sequence of alphanumeric +-- characters, underscores, or single quote that begins with an +-- upper-case letter. +parseHaskellConstructor :: Parser Text +parseHaskellConstructor = + T.pack <$> ((:) <$> large <*> many (small <|> + large <|> + digit' <|> + char '\'' <|> + char '_')) + where small = satisfy isLower + large = satisfy isUpper + digit' = satisfy isDigit + +-- | Parse a Haskell identifer: a sequence of alphanumeric +-- characters, underscores, or a single quote. This matches both +-- variable and constructor names. +parseHaskellIdent :: Parser Text +parseHaskellIdent = + T.pack <$> ((:) <$> (large <|> small) + <*> many (small <|> + large <|> + digit' <|> + char '\'' <|> + char '_')) + where small = satisfy isLower + large = satisfy isUpper + digit' = satisfy isDigit + +-- Ensure that a given character has the given Unicode category +hasCat :: [GeneralCategory] -> Parser Char +hasCat cats = satisfy (flip hasCategory cats) + +xidStart :: [GeneralCategory] +xidStart = [ UppercaseLetter + , LowercaseLetter + , TitlecaseLetter + , ModifierLetter + , OtherLetter + , LetterNumber + ] + +xidContinue :: [GeneralCategory] +xidContinue = xidStart ++ [ NonSpacingMark + , SpacingCombiningMark + , DecimalNumber + , ConnectorPunctuation + ] + +-- | Parse an identifier of unicode characters of the form +-- @ *@, which corresponds strongly +-- to the identifiers found in most C-like languages. Note that +-- the @XID_Start@ category does not include the underscore, +-- so @__foo@ is not a valid XID identifier. To parse +-- identifiers that may include leading underscores, use +-- 'parseXIDIdentGeneral'. +parseXIDIdentStrict :: Parser Text +parseXIDIdentStrict = T.pack <$> ((:) <$> hasCat xidStart + <*> many (hasCat xidContinue)) + +-- | Parse an identifier of unicode characters of the form +-- @( | '_') *@, which corresponds +-- strongly to the identifiers found in most C-like languages. +-- Unlike 'parseXIDIdentStrict', this will also accept an +-- underscore as leading character, which corresponds more +-- closely to programming languages like C and Java, but +-- deviates somewhat from the +-- . +parseXIDIdentGeneral :: Parser Text +parseXIDIdentGeneral = T.pack <$> ((:) <$> (hasCat xidStart <|> char '_') + <*> many (hasCat xidContinue)) -- | A helper function for defining parsers for arbitrary-base integers. -- The first argument will be the base, and the second will be the diff --git a/Data/SCargot/Print.hs b/Data/SCargot/Print.hs --- a/Data/SCargot/Print.hs +++ b/Data/SCargot/Print.hs @@ -180,10 +180,13 @@ where pHead _ SNil = "()" pHead _ (SAtom a) = atomPrinter a pHead ind (SCons x xs) = gather ind x xs id - gather _ _ (SAtom _) _ = error "no dotted pretty printing yet!" gather ind h (SCons x xs) k = gather ind h xs (k . (x:)) - gather ind h SNil k = "(" <> hd <> body <> ")" - where hd = indentSubsequent ind [pHead (ind+1) h] + gather ind h end k = "(" <> hd <> body <> tl <> ")" + where tl = case end of + SNil -> "" + SAtom a -> " . " <> atomPrinter a + SCons _ _ -> error "[unreachable]" + hd = indentSubsequent ind [pHead (ind+1) h] lst = k [] flat = T.unwords (map (pHead (ind+1)) lst) headWidth = T.length hd + 1 diff --git a/Data/SCargot/Repr/Basic.hs b/Data/SCargot/Repr/Basic.hs --- a/Data/SCargot/Repr/Basic.hs +++ b/Data/SCargot/Repr/Basic.hs @@ -72,14 +72,6 @@ cons :: SExpr a -> SExpr a -> SExpr a cons = SCons -mkList :: [SExpr a] -> SExpr a -mkList [] = SNil -mkList (x:xs) = SCons x (mkList xs) - -mkDList :: [SExpr a] -> a -> SExpr a -mkDList [] a = SAtom a -mkDList (x:xs) a = SCons x (mkDList xs a) - gatherDList :: SExpr a -> Maybe ([SExpr a], a) gatherDList SNil = Nothing gatherDList SAtom {} = Nothing @@ -96,37 +88,44 @@ -- -- >>> A "pachy" ::: A "derm" -- SCons (SAtom "pachy") (SAtom "derm") +pattern (:::) :: SExpr a -> SExpr a -> SExpr a pattern x ::: xs = SCons x xs -- | A shorter alias for `SAtom` -- -- >>> A "elephant" -- SAtom "elephant" +pattern A :: a -> SExpr a pattern A x = SAtom x -- | A (slightly) shorter alias for `SNil` -- -- >>> Nil -- SNil +pattern Nil :: SExpr a pattern Nil = SNil -- | An alias for matching a proper list. -- -- >>> L [A "pachy", A "derm"] --- SCons (SAtom "pachy") (SCons (SAtom "derm") SNil) +-- SExpr (SAtom "pachy") (SExpr (SAtom "derm") SNil) +pattern L :: [SExpr a] -> SExpr a pattern L xs <- (gatherList -> Right xs) #if MIN_VERSION_base(4,8,0) - where L xs = mkList xs + where L [] = SNil + L (x:xs) = SCons x (L xs) #endif -- | An alias for matching a dotted list. -- -- >>> DL [A "pachy"] A "derm" --- SCons (SAtom "pachy") (SAtom "derm") +-- SExpr (SAtom "pachy") (SAtom "derm") +pattern DL :: [SExpr a] -> a -> SExpr a pattern DL xs x <- (gatherDList -> Just (xs, x)) #if MIN_VERSION_base(4,8,0) - where DL xs x = mkDList xs x + where DL [] a = SAtom a + DL (x:xs) a = SCons x (DL xs a) #endif getShape :: SExpr a -> String diff --git a/Data/SCargot/Repr/Rich.hs b/Data/SCargot/Repr/Rich.hs --- a/Data/SCargot/Repr/Rich.hs +++ b/Data/SCargot/Repr/Rich.hs @@ -107,6 +107,7 @@ -- -- >>> A "one" ::: L [A "two", A "three"] -- RSList [RSAtom "one",RSAtom "two",RSAtom "three"] +pattern (:::) :: RichSExpr a -> RichSExpr a -> RichSExpr a pattern x ::: xs <- (uncons -> Just (x, xs)) #if MIN_VERSION_base(4,8,0) where x ::: xs = cons x xs @@ -116,24 +117,28 @@ -- -- >>> A "elephant" -- RSAtom "elephant" -pattern A a = R.RSAtom a +pattern A :: a -> RichSExpr a +pattern A a = R.RSAtom a -- | A shorter alias for `RSList` -- -- >>> L [A "pachy", A "derm"] -- RSList [RSAtom "pachy",RSAtom "derm"] -pattern L xs = R.RSList xs +pattern L :: [RichSExpr a] -> RichSExpr a +pattern L xs = R.RSList xs -- | A shorter alias for `RSDotted` -- -- >>> DL [A "pachy"] "derm" -- RSDotted [RSAtom "pachy"] "derm" +pattern DL :: [RichSExpr a] -> a -> RichSExpr a pattern DL xs x = R.RSDotted xs x -- | A shorter alias for `RSList` @[]@ -- -- >>> Nil -- RSList [] +pattern Nil :: RichSExpr a pattern Nil = R.RSList [] -- | Utility function for parsing a pair of things: this parses a two-element list, diff --git a/Data/SCargot/Repr/WellFormed.hs b/Data/SCargot/Repr/WellFormed.hs --- a/Data/SCargot/Repr/WellFormed.hs +++ b/Data/SCargot/Repr/WellFormed.hs @@ -59,24 +59,28 @@ -- instead. -- -- >>> let sum (x ::: xs) = x + sum xs; sum Nil = 0 +pattern (:::) :: WellFormedSExpr a -> WellFormedSExpr a -> WellFormedSExpr a pattern x ::: xs <- (uncons -> Just (x, xs)) -- | A shorter alias for `WFSList` -- -- >>> L [A "pachy", A "derm"] -- WFSList [WFSAtom "pachy",WFSAtom "derm"] +pattern L :: [WellFormedSExpr t] -> WellFormedSExpr t pattern L xs = R.WFSList xs -- | A shorter alias for `WFSAtom` -- -- >>> A "elephant" -- WFSAtom "elephant" +pattern A :: t -> WellFormedSExpr t pattern A a = R.WFSAtom a -- | A shorter alias for `WFSList` @[]@ -- -- >>> Nil -- WFSList [] +pattern Nil :: WellFormedSExpr t pattern Nil = R.WFSList [] getShape :: WellFormedSExpr a -> String diff --git a/example/example.hs b/example/example.hs new file mode 100644 --- /dev/null +++ b/example/example.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Applicative ((<|>)) +import Data.Char (isDigit) +import Data.SCargot +import Data.SCargot.Repr.Basic +import Data.Text (Text, pack) +import Numeric (readHex) +import System.Environment (getArgs) +import Text.Parsec (anyChar, char, digit, many1, manyTill, newline, satisfy, string) +import Text.Parsec.Text (Parser) + +-- Our operators are going to represent addition, subtraction, or +-- multiplication +data Op = Add | Sub | Mul deriving (Eq, Show) + +-- The atoms of our language are either one of the aforementioned +-- operators, or positive integers +data Atom = AOp Op | ANum Int deriving (Eq, Show) + +-- Once parsed, our language will consist of the applications of +-- binary operators with literal integers at the leaves +data Expr = EOp Op Expr Expr | ENum Int deriving (Eq, Show) + +-- Conversions to and from our Expr type +toExpr :: SExpr Atom -> Either String Expr +toExpr (A (AOp op) ::: l ::: r ::: Nil) = EOp op <$> toExpr l <*> toExpr r +toExpr (A (ANum n)) = pure (ENum n) +toExpr sexpr = Left ("Unable to parse expression: " ++ show sexpr) + +fromExpr :: Expr -> SExpr Atom +fromExpr (EOp op l r) = A (AOp op) ::: fromExpr l ::: fromExpr r ::: Nil +fromExpr (ENum n) = A (ANum n) ::: Nil + +-- Parser and serializer for our Atom type +pAtom :: Parser Atom +pAtom = ((ANum . read) <$> many1 digit) + <|> (char '+' *> pure (AOp Add)) + <|> (char '-' *> pure (AOp Sub)) + <|> (char '*' *> pure (AOp Mul)) + +sAtom :: Atom -> Text +sAtom (AOp Add) = "+" +sAtom (AOp Sub) = "-" +sAtom (AOp Mul) = "*" +sAtom (ANum n) = pack (show n) + +-- Our comment syntax is going to be Haskell-like: +hsComment :: Parser () +hsComment = string "--" >> manyTill anyChar newline >> return () + +-- Our custom reader macro: grab the parse stream and read a +-- hexadecimal number from it: +hexReader :: Reader Atom +hexReader _ = (A . ANum . rd) <$> many1 (satisfy isHexDigit) + where isHexDigit c = isDigit c || c `elem` hexChars + rd = fst . head . readHex + hexChars :: String + hexChars = "AaBbCcDdEeFf" + +-- Our final s-expression parser and printer: +myLangParser :: SExprParser Atom Expr +myLangParser + = setComment hsComment -- set comment syntax to be Haskell-style + $ addReader '#' hexReader -- add hex reader + $ setCarrier toExpr -- convert final repr to Expr + $ mkParser pAtom -- create spec with Atom type + +mkLangPrinter :: SExprPrinter Atom Expr +mkLangPrinter + = setFromCarrier fromExpr + $ setIndentStrategy (const Align) + $ basicPrint sAtom + + +main :: IO () +main = do + sExprText <- pack <$> getContents + either putStrLn print (decode myLangParser sExprText) + +{- +Example usage: + +$ dist/build/example/example < -- you can put comments in the code! +> (+ 10 (* 20 20)) +> -- and more than one s-expression! +> (* 10 10) +> EOF +[EOp Add (ENum 10) (EOp Mul (ENum 20) (ENum 20)),EOp Mul (ENum 10) (ENum 10)] +-} diff --git a/s-cargot.cabal b/s-cargot.cabal --- a/s-cargot.cabal +++ b/s-cargot.cabal @@ -1,5 +1,5 @@ name: s-cargot -version: 0.1.0.0 +version: 0.1.1.0 synopsis: A flexible, extensible s-expression library. homepage: https://github.com/aisamanra/s-cargot description: S-Cargot is a library for working with s-expressions in @@ -20,9 +20,13 @@ cabal-version: >=1.10 source-repository head - type: git - location: git://github.com/aisamanra/s-cargot.git + type: git + location: git://github.com/aisamanra/s-cargot.git +flag build-example + description: Build example application + default: False + library exposed-modules: Data.SCargot, Data.SCargot.Repr, @@ -42,3 +46,28 @@ default-language: Haskell2010 default-extensions: CPP ghc-options: -Wall + +executable example + if flag(build-example) + main-is: example.hs + else + buildable: False + hs-source-dirs: example + build-depends: base >=4.7 && <5, + containers >=0.5 && <1, + parsec >=3.1 && <4, + s-cargot , + text >=1.2 && <2 + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + +test-suite s-cargot-qc + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: SCargotQC.hs + build-depends: s-cargot, + base >=4.7 && <5, + parsec >=3.1 && <4, + QuickCheck >=2.8 && <3, + text >=1.2 && <2 diff --git a/test/SCargotQC.hs b/test/SCargotQC.hs new file mode 100644 --- /dev/null +++ b/test/SCargotQC.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.SCargot.ReprQC (reprQC) where + +import Data.SCargot ( SExprParser + , SExprPrinter + , mkParser + , flatPrint + , encodeOne + , decodeOne + , asRich + , asWellFormed + ) +import Data.SCargot.Repr ( SExpr(..) + , RichSExpr + , fromRich + , toRich + , WellFormedSExpr(..) + , fromWellFormed + , toWellFormed + ) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary +import Text.Parsec (char) +import Text.Parsec.Text (Parser) + +instance Arbitrary a => Arbitrary (SExpr a) where + arbitrary = sized $ \n -> + if n <= 0 + then pure SNil + else oneof [ SAtom <$> arbitrary + , do + k <- choose (0, n) + elems <- sequence [ resize (n-k) arbitrary + | _ <- [0..k] + ] + tail <- oneof [ SAtom <$> arbitrary + , pure SNil + ] + pure (foldr SCons tail elems) + ] + +instance Arbitrary a => Arbitrary (RichSExpr a) where + arbitrary = toRich `fmap` arbitrary + +instance Arbitrary a => Arbitrary (WellFormedSExpr a) where + arbitrary = sized $ \n -> + oneof [ WFSAtom <$> arbitrary + , do + k <- choose (0, n) + WFSList <$> sequence + [ resize (n-k) arbitrary + | _ <- [0..k] + ] + ] + +parser :: SExprParser () (SExpr ()) +parser = mkParser (() <$ char 'X') + +printer :: SExprPrinter () (SExpr ()) +printer = flatPrint (const "X") + +richIso :: SExpr () -> Bool +richIso s = fromRich (toRich s) == s + +richIsoBk :: RichSExpr () -> Bool +richIsoBk s = toRich (fromRich s) == s + + +wfIso :: SExpr () -> Bool +wfIso s = case toWellFormed s of + Left _ -> True + Right y -> s == fromWellFormed y + +wfIsoBk :: WellFormedSExpr () -> Bool +wfIsoBk s = toWellFormed (fromWellFormed s) == Right s + + +encDec :: SExpr () -> Bool +encDec s = decodeOne parser (encodeOne printer s) == Right s + +encDecRich :: RichSExpr () -> Bool +encDecRich s = decodeOne (asRich parser) (encodeOne printer (fromRich s)) + == Right s + +encDecWF :: WellFormedSExpr () -> Bool +encDecWF s = decodeOne (asWellFormed parser) (encodeOne printer (fromWellFormed s)) + == Right s + +reprQC :: IO () +reprQC = do + putStrLn "The SExpr <--> Rich translation should be isomorphic" + quickCheck richIso + quickCheck richIsoBk + putStrLn "The SExpr <--> WF translation should be near-isomorphic" + quickCheck wfIso + quickCheck wfIsoBk + putStrLn "This should be true when parsing, as well" + quickCheck encDec + quickCheck encDecRich + quickCheck encDecWF