s-cargot 0.1.0.0 → 0.1.1.0
raw patch · 9 files changed
+359/−21 lines, 9 filesdep +QuickCheckdep +s-cargotnew-component:exe:example
Dependencies added: QuickCheck, s-cargot
Files
- Data/SCargot/Comments.hs +12/−0
- Data/SCargot/Common.hs +93/−1
- Data/SCargot/Print.hs +6/−3
- Data/SCargot/Repr/Basic.hs +11/−12
- Data/SCargot/Repr/Rich.hs +7/−2
- Data/SCargot/Repr/WellFormed.hs +4/−0
- example/example.hs +93/−0
- s-cargot.cabal +32/−3
- test/SCargotQC.hs +101/−0
Data/SCargot/Comments.hs view
@@ -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
Data/SCargot/Common.hs view
@@ -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+-- @<XID_Start> <XID_Continue>*@, 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+-- @(<XID_Start> | '_') <XID_Continue>*@, 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+-- <http://unicode.org/reports/tr31/ Unicode Identifier and+-- Pattern Syntax standard>.+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
Data/SCargot/Print.hs view
@@ -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
Data/SCargot/Repr/Basic.hs view
@@ -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
Data/SCargot/Repr/Rich.hs view
@@ -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,
Data/SCargot/Repr/WellFormed.hs view
@@ -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
+ example/example.hs view
@@ -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 <<EOF+> -- 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)]+-}
s-cargot.cabal view
@@ -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
+ test/SCargotQC.hs view
@@ -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