packages feed

stdata (empty) → 0.0.1

raw patch · 9 files changed

+1011/−0 lines, 9 filesdep +basedep +parsecdep +sybsetup-changed

Dependencies added: base, parsec, syb, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright David Darais 2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of David Darais nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ src/Data/SExp.hs view
@@ -0,0 +1,10 @@+module Data.SExp+  ( module Data.SExp.Data+  , module Data.SExp.Parse+  ) where++import Data.SExp.Data+import Data.SExp.Parse++demo1 :: String+demo1 = "(something cool(abc d))"
+ src/Data/SExp/Data.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.SExp.Data +  ( Atom(..), AntiAtom(..)+  , OpenLink(..) , OpenSExp(..)+  , SExp(..), SExpLink(..)+  , DualSExp(..), DualSExpLink(..)+  ) where++import Data.Generics++-- Atoms and Anti-Atoms++data Atom =+    StringAtom String+  | BooleanAtom Bool+  | IntegerAtom Integer+  | FloatingAtom Double+  | SymbolAtom String+  deriving (Eq, Ord, Show, Typeable, Data)++data AntiAtom =+    ValueAntiAtom String+  | AtomAntiAtom String+  | StringAntiAtom String+  | BooleanAntiAtom String+  | IntegerAntiAtom String+  | FloatingAntiAtom String+  | SymbolAntiAtom String+  deriving (Eq, Ord, Show, Typeable, Data)++-- Generic Link Structure++data OpenLink sd sl =+    NullLink+  | ConsLink sd sl+  deriving (Eq, Ord, Show, Typeable, Data)++-- Standard S-Expressions++data OpenSExp sl =+    AtomSExp Atom+  | LinkSExp sl+  deriving (Eq, Ord, Show, Typeable, Data)++newtype SExp = SExp { unSExp :: OpenSExp SExpLink } +  deriving (Eq, Ord, Show, Typeable, Data)+newtype SExpLink = SExpLink { unSExpLink :: OpenLink SExp SExpLink } +  deriving (Eq, Ord, Show, Typeable, Data)++-- Anti S-Expressions++data DualSExp =+    PositiveDualSExp (OpenSExp DualSExpLink)+  | AntiAtomDualSExp AntiAtom+  deriving (Eq, Ord, Show, Typeable, Data)++data DualSExpLink =+    PositiveDualSExpLink (OpenLink DualSExp DualSExpLink)+  | AntiConsDualSExpLink String+  deriving (Eq, Ord, Show, Typeable, Data)+
+ src/Data/SExp/Parse.hs view
@@ -0,0 +1,420 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.SExp.Parse+  ( SExpToken(..)+  , stringTokenValueM, booleanTokenValueM, integerTokenValueM, floatingTokenValueM+  , symbolTokenValueM, lParenTokenValueM, rParenTokenValueM, whitespaceTokenValueM+  , commentTokenValueM, antiConsTokenValueM, antiValueTokenValueM, antiAtomTokenValueM+  , antiStringTokenValueM, antiBooleanTokenValueM, antiIntegerTokenValueM, antiFloatingTokenValueM+  , antiSymbolTokenValueM+  , isDiscardSExpToken+  , sexpTokens+  , lexSExp+  , parseSExp, parseDualSExp+  , convertAtomE, convertAntiAtomToAtomE+  , convertOpenLinkE+  , convertAtomP, convertAntiAtomToAtomP+  , convertOpenLinkP+  , sexp, sexpl+  , lexOne, tokParse, qtokParse+  ) where++import Control.Monad+import Data.SExp.Data+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Parsec+import Text.Parsec.Pos+import Text.Parsec.String+import Text.Printf++-- Lexing++data SExpToken =+  -- Atom Tokens+    StringToken String+  | BooleanToken Bool+  | IntegerToken Integer+  | FloatingToken Double+  | SymbolToken String++  -- Structure Tokens+  | LParenToken+  | RParenToken++  -- Filtered Tokens+  | WhitespaceToken+  | CommentToken String++  -- Anti Tokens+  | AntiConsToken+  | AntiValueToken String+  | AntiAtomToken String+  | AntiStringToken String+  | AntiBooleanToken String+  | AntiIntegerToken String+  | AntiFloatingToken String+  | AntiSymbolToken String+  deriving (Eq, Ord, Show)++isDiscardSExpToken :: SExpToken -> Bool+isDiscardSExpToken WhitespaceToken = True+isDiscardSExpToken (CommentToken _) = True+isDiscardSExpToken _ = False++stringTokenValueM :: SExpToken -> Maybe String+stringTokenValueM t = case t of (StringToken s) -> Just s ; _ -> Nothing+booleanTokenValueM :: SExpToken -> Maybe Bool+booleanTokenValueM t = case t of (BooleanToken b) -> Just b ; _ -> Nothing+integerTokenValueM :: SExpToken -> Maybe Integer+integerTokenValueM t = case t of (IntegerToken i) -> Just i ; _ -> Nothing+floatingTokenValueM :: SExpToken -> Maybe Double+floatingTokenValueM t = case t of (FloatingToken f) -> Just f ; _ -> Nothing+symbolTokenValueM :: SExpToken -> Maybe String+symbolTokenValueM t = case t of (SymbolToken s) -> Just s ; _ -> Nothing+lParenTokenValueM :: SExpToken -> Maybe ()+lParenTokenValueM t = case t of LParenToken -> Just () ; _ -> Nothing+rParenTokenValueM :: SExpToken -> Maybe ()+rParenTokenValueM t = case t of RParenToken -> Just () ; _ -> Nothing+whitespaceTokenValueM :: SExpToken -> Maybe ()+whitespaceTokenValueM t = case t of WhitespaceToken -> Just () ; _ -> Nothing+commentTokenValueM :: SExpToken -> Maybe String+commentTokenValueM t = case t of (CommentToken s) -> Just s  ; _ -> Nothing+antiConsTokenValueM :: SExpToken -> Maybe ()+antiConsTokenValueM t = case t of AntiConsToken -> Just () ; _ -> Nothing+antiValueTokenValueM :: SExpToken -> Maybe String+antiValueTokenValueM t = case t of (AntiValueToken n) -> Just n ; _ -> Nothing+antiAtomTokenValueM :: SExpToken -> Maybe String+antiAtomTokenValueM t = case t of (AntiAtomToken n) -> Just n ; _ -> Nothing+antiStringTokenValueM :: SExpToken -> Maybe String+antiStringTokenValueM t = case t of (AntiStringToken n) -> Just n ; _ -> Nothing+antiBooleanTokenValueM :: SExpToken -> Maybe String+antiBooleanTokenValueM t = case t of (AntiBooleanToken n) -> Just n ; _ -> Nothing+antiIntegerTokenValueM :: SExpToken -> Maybe String+antiIntegerTokenValueM t = case t of (AntiIntegerToken n) -> Just n ; _ -> Nothing+antiFloatingTokenValueM :: SExpToken -> Maybe String+antiFloatingTokenValueM t = case t of (AntiFloatingToken n) -> Just n ; _ -> Nothing+antiSymbolTokenValueM :: SExpToken -> Maybe String+antiSymbolTokenValueM t = case t of (AntiSymbolToken n) -> Just n ; _ -> Nothing++sexpTokens :: [Parser SExpToken]+sexpTokens = +  [+  -- Atom Tokens+    let inside = many $ noneOf "\"\\" <|> esc+        esc = char '\\' >> msum [escQuote, escEsc, escNewline]+        escQuote = char '"'+        escEsc = char '\\'+        escNewline = char 'n' >> return '\n'+    in liftM StringToken $ between (char '"') (char '"') inside+  , string "true" >> return (BooleanToken True)+  , string "false" >> return (BooleanToken False)+  , do+      sign <- option "" $ string "-"+      num <- many1 digit+      return . IntegerToken . read $ sign ++ num+  , do+      sign <- option "" $ string "-"+      num <- many1 digit+      decimal <- option "" $ do+        dot <- string "."+        followDot <- many1 digit+        return $ dot ++ followDot+      exponential <- option "" $ do+        leading <- string "e"+        followExp <- many1 digit+        return $ leading ++ followExp+      return . FloatingToken . read $ sign ++ num ++ decimal ++ exponential+  , liftM SymbolToken $ do { a <- noneOf " \t\n@#()\"\\" ; b <- many (noneOf " \t\n#()\"\\") ; return $ a:b }++  -- Structure Tokens+  , char '(' >> return LParenToken+  , char ')' >> return RParenToken++  -- Filtered Tokens+  , many1 (oneOf " \t\n") >> return WhitespaceToken+  , do  +      a <- liftM (:[]) $ char '#' +      b <- option "" $ do+        j <- liftM (:[]) $ noneOf "|\n"+        k <- many (noneOf "\n")+        return $ j ++ k+      c <- liftM (:[]) $ char '\n' +      return . CommentToken $ concat [a, b, c]+  , let inside :: Int -> Parser String+        inside n = if n == 0 then return "" else msum +          [ do { a <- noneOf "#|" ; b <- inside n ; return $ a:b }+          , do { a <- char '#' ; b <- insidePostPound n ; return $ a:b }+          , do { a <- char '|' ; b <- insidePostPipe n ; return $ a:b }+          ]+        insidePostPound n = msum+          [ do { a <- noneOf "#|" ; b <- inside n ; return $ a:b }+          , do { a <- char '#' ; b <- insidePostPound n ; return $ a:b }+          , do { a <- char '|' ; b <- inside (n + 1) ; return $ a:b }+          ]+        insidePostPipe n = msum+          [ do { a <- noneOf "#|" ; b <- inside n ; return $ a:b }+          , do { a <- char '|' ; b <- insidePostPipe n ; return $ a:b }+          , if n == 0 then mzero else do { a <- char '#' ; b <- inside (n - 1) ; return $ a:b }+          ]+    in do { a <- string "#|" ; b <- inside 1 ; return . CommentToken $ a ++ b }++  -- Anti Tokens+  , string "@~" >> return AntiConsToken+  , string "@:" >> liftM AntiValueToken antiName+  , string "@atom:" >> liftM AntiAtomToken antiName+  , string "@string:" >> liftM AntiStringToken antiName+  , string "@boolean:" >> liftM AntiBooleanToken antiName+  , string "@integer:" >> liftM AntiIntegerToken antiName+  , string "@floating:" >> liftM AntiFloatingToken antiName+  , string "@symbol:" >> liftM AntiSymbolToken antiName+  ]+  where+    antiName = do+      a <- letter <|> char '_'+      as <- many (alphaNum <|> oneOf "_'")+      return (a:as)++lexSExp :: String -> Either String [(SourcePos, SExpToken)]+lexSExp i = do+  (result, o, i') <- lexSExp' (initialPos "") i+  case i' of+    [] -> return $ filter (not . isDiscardSExpToken . snd) result+    _ -> fail $ printf "did not consume all input: %s" (show o) ++lexSExp' :: SourcePos -> String -> Either String ([(SourcePos, SExpToken)], SourcePos, String)+lexSExp' o [] = return ([], o, [])+lexSExp' o i = do+  (lexed, o', i') <- lexOne o sexpTokens i+  (rest, o'', i'') <- lexSExp' o' i'+  return (lexed : rest, o'', i'')++-- Parsing++type SExpParser a = GenParser (SourcePos, SExpToken) () a++sexpTokenParser :: (SExpToken -> Maybe a) -> SExpParser a+sexpTokenParser f = token show fst (f . snd)++stringTok       :: SExpParser String  ; stringTok       = sexpTokenParser stringTokenValueM+booleanTok      :: SExpParser Bool    ; booleanTok      = sexpTokenParser booleanTokenValueM+integerTok      :: SExpParser Integer ; integerTok      = sexpTokenParser integerTokenValueM+floatingTok     :: SExpParser Double  ; floatingTok     = sexpTokenParser floatingTokenValueM+symbolTok       :: SExpParser String  ; symbolTok       = sexpTokenParser symbolTokenValueM+lParenTok       :: SExpParser ()      ; lParenTok       = sexpTokenParser lParenTokenValueM+rParenTok       :: SExpParser ()      ; rParenTok       = sexpTokenParser rParenTokenValueM+antiConsTok     :: SExpParser ()      ; antiConsTok     = sexpTokenParser antiConsTokenValueM+antiValueTok    :: SExpParser String  ; antiValueTok    = sexpTokenParser antiValueTokenValueM+antiAtomTok     :: SExpParser String  ; antiAtomTok     = sexpTokenParser antiAtomTokenValueM+antiStringTok   :: SExpParser String  ; antiStringTok   = sexpTokenParser antiStringTokenValueM+antiBooleanTok  :: SExpParser String  ; antiBooleanTok  = sexpTokenParser antiBooleanTokenValueM+antiIntegerTok  :: SExpParser String  ; antiIntegerTok  = sexpTokenParser antiIntegerTokenValueM+antiFloatingTok :: SExpParser String  ; antiFloatingTok = sexpTokenParser antiFloatingTokenValueM+antiSymbolTok   :: SExpParser String  ; antiSymbolTok   = sexpTokenParser antiSymbolTokenValueM++atomP :: SExpParser Atom+atomP = msum+  [ liftM StringAtom stringTok+  , liftM BooleanAtom booleanTok+  , liftM IntegerAtom integerTok+  , liftM FloatingAtom floatingTok+  , liftM SymbolAtom symbolTok+  ]++antiAtomP :: SExpParser AntiAtom+antiAtomP = msum+  [ liftM ValueAntiAtom antiValueTok+  , liftM AtomAntiAtom antiAtomTok+  , liftM StringAntiAtom antiStringTok+  , liftM BooleanAntiAtom antiBooleanTok+  , liftM IntegerAntiAtom antiIntegerTok+  , liftM FloatingAntiAtom antiFloatingTok+  , liftM SymbolAntiAtom antiSymbolTok+  ]++sexpP :: SExpParser SExp+sexpP = msum+  [ liftM (SExp . AtomSExp) atomP+  , liftM (SExp . LinkSExp) $ between lParenTok rParenTok sexpLinkP+  ]++sexpLinkP :: SExpParser SExpLink+sexpLinkP = msum+  [ do+      s <- sexpP+      ss <- sexpLinkP+      return . SExpLink $ ConsLink s ss+  , return $ SExpLink NullLink+  ]++dualSExpP :: SExpParser DualSExp+dualSExpP = msum+  [ liftM (PositiveDualSExp . AtomSExp) atomP+  , liftM AntiAtomDualSExp antiAtomP+  , liftM (PositiveDualSExp . LinkSExp) $ between lParenTok rParenTok dualSExpLinkP+  ]++dualSExpLinkP :: SExpParser DualSExpLink+dualSExpLinkP = msum+  [ do +      s <- dualSExpP +      ss <- dualSExpLinkP +      return . PositiveDualSExpLink $ ConsLink s ss+  , do +      antiConsTok +      anti <- antiValueTok +      return $ AntiConsDualSExpLink anti+  , return $ PositiveDualSExpLink NullLink+  ]++parseSExp :: String -> Either String SExp+parseSExp = tokParse lexSExp sexpP++parseDualSExp :: String -> Either String DualSExp+parseDualSExp = tokParse lexSExp dualSExpP++-- Quasi Quoting++convertAtomE :: Atom -> Q Exp+convertAtomE (StringAtom s) = conE 'StringAtom `appE` litE (stringL s)+convertAtomE (BooleanAtom True) = conE 'BooleanAtom `appE` conE 'True+convertAtomE (BooleanAtom False) = conE 'BooleanAtom `appE` conE 'False+convertAtomE (IntegerAtom i) = conE 'IntegerAtom `appE` litE (integerL i)+convertAtomE (FloatingAtom f) = conE 'FloatingAtom `appE` litE (rationalL (toRational f))+convertAtomE (SymbolAtom s) = conE 'SymbolAtom `appE` litE (stringL s)++convertAntiAtomToAtomE :: AntiAtom -> Q Exp+convertAntiAtomToAtomE (ValueAntiAtom name) = varE $ mkName name+convertAntiAtomToAtomE (AtomAntiAtom name) = conE 'SExp `appE` conE 'AtomSExp `appE` varE (mkName name)+convertAntiAtomToAtomE (StringAntiAtom name) = mkAntiAtomE 'StringAtom $ mkName name+convertAntiAtomToAtomE (BooleanAntiAtom name) = mkAntiAtomE 'BooleanAtom $ mkName name+convertAntiAtomToAtomE (IntegerAntiAtom name) = mkAntiAtomE 'IntegerAtom $ mkName name+convertAntiAtomToAtomE (FloatingAntiAtom name) = mkAntiAtomE 'FloatingAtom $ mkName name+convertAntiAtomToAtomE (SymbolAntiAtom name) = mkAntiAtomE 'SymbolAtom $ mkName name++mkAntiAtomE :: Name -> Name -> Q Exp+mkAntiAtomE conName varName = conE 'AtomSExp `appE` conE conName `appE` varE varName++convertOpenSExpE :: (l -> Q Exp) -> OpenSExp l -> Q Exp+convertOpenSExpE _ (AtomSExp a) = conE 'AtomSExp `appE` convertAtomE a+convertOpenSExpE cl (LinkSExp l) = conE 'LinkSExp `appE` cl l++convertOpenLinkE :: (a -> Q Exp) -> (l -> Q Exp) -> OpenLink a l -> Q Exp+convertOpenLinkE _ _ NullLink = conE 'NullLink+convertOpenLinkE ch cl (ConsLink h l) = conE 'ConsLink `appE` ch h `appE` cl l++convertDualSExpToSExpE :: DualSExp -> Q Exp+convertDualSExpToSExpE (PositiveDualSExp p) = +  conE 'SExp `appE` convertOpenSExpE convertDualSExpToSExpLinkE p+convertDualSExpToSExpE (AntiAtomDualSExp aa) = +  conE 'SExp `appE` conE 'AtomSExp `appE` convertAntiAtomToAtomE aa++convertDualSExpToSExpLinkE :: DualSExpLink -> Q Exp+convertDualSExpToSExpLinkE (PositiveDualSExpLink p) = +  conE 'SExpLink `appE` convertOpenLinkE convertDualSExpToSExpE convertDualSExpToSExpLinkE p+convertDualSExpToSExpLinkE (AntiConsDualSExpLink name) =+  conE 'SExpLink `appE` varE (mkName name)++convertAtomP :: Atom -> Q Pat+convertAtomP (StringAtom s) = conP 'StringAtom [litP (stringL s)]+convertAtomP (BooleanAtom True) = conP 'BooleanAtom [conP 'True []]+convertAtomP (BooleanAtom False) = conP 'BooleanAtom [conP 'False []]+convertAtomP (IntegerAtom i) = conP 'IntegerAtom [litP (integerL i)]+convertAtomP (FloatingAtom f) = conP 'FloatingAtom [litP (rationalL (toRational f))]+convertAtomP (SymbolAtom s) = conP 'SymbolAtom [litP (stringL s)]++convertAntiAtomToAtomP :: AntiAtom -> Q Pat+convertAntiAtomToAtomP (ValueAntiAtom "_") = wildP+convertAntiAtomToAtomP (ValueAntiAtom name) = varP $ mkName name+convertAntiAtomToAtomP (AtomAntiAtom "_") = conP 'AtomSExp [wildP]+convertAntiAtomToAtomP (AtomAntiAtom name) = conP 'AtomSExp [varP (mkName name)]+convertAntiAtomToAtomP (StringAntiAtom "_") = mkWildAtomP 'StringAtom+convertAntiAtomToAtomP (StringAntiAtom name) = mkAntiAtomP 'StringAtom $ mkName name+convertAntiAtomToAtomP (BooleanAntiAtom "_") = mkWildAtomP 'BooleanAtom+convertAntiAtomToAtomP (BooleanAntiAtom name) = mkAntiAtomP 'BooleanAtom $ mkName name+convertAntiAtomToAtomP (IntegerAntiAtom "_") = mkWildAtomP 'IntegerAtom+convertAntiAtomToAtomP (IntegerAntiAtom name) = mkAntiAtomP 'IntegerAtom $ mkName name+convertAntiAtomToAtomP (FloatingAntiAtom "_") = mkWildAtomP 'FloatingAtom+convertAntiAtomToAtomP (FloatingAntiAtom name) = mkAntiAtomP 'FloatingAtom $ mkName name+convertAntiAtomToAtomP (SymbolAntiAtom "_") = mkWildAtomP 'SymbolAtom+convertAntiAtomToAtomP (SymbolAntiAtom name) = mkAntiAtomP 'SymbolAtom $ mkName name++mkAntiAtomP :: Name -> Name -> Q Pat+mkAntiAtomP conName varName = conP conName [varP varName]+mkWildAtomP :: Name -> Q Pat+mkWildAtomP conName = conP conName [wildP]++convertOpenSExpP :: (l -> Q Pat) -> OpenSExp l -> Q Pat+convertOpenSExpP _ (AtomSExp a) = conP 'AtomSExp [convertAtomP a]+convertOpenSExpP cl (LinkSExp l) = conP 'LinkSExp [cl l]++convertOpenLinkP :: (a -> Q Pat) -> (l -> Q Pat) -> OpenLink a l -> Q Pat+convertOpenLinkP _ _ NullLink = conP 'NullLink []+convertOpenLinkP ch cl (ConsLink h l) = conP 'ConsLink [ch h, cl l]++convertDualSExpToSExpP :: DualSExp -> Q Pat+convertDualSExpToSExpP (PositiveDualSExp p) =+  conP 'SExp [convertOpenSExpP convertDualSExpToSExpLinkP p]+convertDualSExpToSExpP (AntiAtomDualSExp aa) =+  conP 'SExp [conP 'AtomSExp [convertAntiAtomToAtomP aa]]++convertDualSExpToSExpLinkP :: DualSExpLink -> Q Pat+convertDualSExpToSExpLinkP (PositiveDualSExpLink p) = +  conP 'SExpLink [convertOpenLinkP convertDualSExpToSExpP convertDualSExpToSExpLinkP p]+convertDualSExpToSExpLinkP (AntiConsDualSExpLink name) =+  conP 'SExpLink [varP (mkName name)]++sexp :: QuasiQuoter+sexp = QuasiQuoter +  { quoteExp = convertDualSExpToSExpE <=< qtokParse lexSExp dualSExpP+  , quotePat = convertDualSExpToSExpP <=< qtokParse lexSExp dualSExpP+  , quoteType = undefined+  , quoteDec = undefined+  }++sexpl :: QuasiQuoter+sexpl = QuasiQuoter +  { quoteExp = convertDualSExpToSExpLinkE <=< qtokParse lexSExp dualSExpLinkP+  , quotePat = convertDualSExpToSExpLinkP <=< qtokParse lexSExp dualSExpLinkP+  , quoteType = undefined+  , quoteDec = undefined+  }++-- Helpers++lexOne :: (Ord a) => SourcePos -> [Parser a] -> String -> Either String ((SourcePos, a), SourcePos, String)+lexOne pos ps input = do+  (a, b, c) <- foldl findBest (Left $ printf "could not lex at %s: %s" (show pos) (show input)) $ map tryP ps+  return ((pos, a), b, c)+  where+    tryP p = left show $ parse p' "" input+      where+        p' = do+          setPosition pos+          x <- p+          i <- getInput+          o <- getPosition+          return (x, o, i)+    findBest x@(Left _) (Left _) = x+    findBest (Left _) x@(Right _) = x+    findBest x@(Right _) (Left _) = x+    findBest x1@(Right (_, p1, _)) x2@(Right (_, p2, _))+      | p2 > p1 = x2+      | otherwise = x1++    left :: (a -> b) -> Either a c -> Either b c+    left f (Left x) = Left (f x)+    left _ (Right x) = Right x++tokParse :: (String -> Either String [tok]) -> GenParser tok () a -> String -> Either String a+tokParse lexify p input = do+  lexed <- lexify input+  left show $ parse p "" lexed+  where+    left f (Left x) = Left (f x)+    left _ (Right x) = Right x++qtokParse :: (String -> Either String [tok]) -> GenParser tok () a -> String -> Q a+qtokParse lexify p input = case tokParse lexify p input  of+  (Left e) -> runIO $ fail e+  (Right r) -> return r
+ src/Data/STData.hs view
@@ -0,0 +1,11 @@+module Data.STData+  ( module Data.STData.Data+  , module Data.STData.Parse+  ) where++import Data.STData.Data+import Data.STData.Parse++demo2 :: String+demo2 = "(a b t(-( yo here is a ton ) of stuff ( s(-(embedded structure)-) more text hooray! )-) (s))"+
+ src/Data/STData/Data.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Data.STData.Data+  ( OpenSData(..), OpenTData(..)+  , SData(..), SLink(..), TData(..), TLink(..)+  , DualSData(..), DualSLink(..), DualTData(..), DualTLink(..)+  , sdataToList+  ) where++import Data.Generics+import Text.Printf+import Data.SExp++-- Standard ST-Data++data OpenSData sl tl =+    AtomSData Atom             -- x+  | SLinkSData sl              -- ( ... )+  | TLinkSData tl              -- t(-( ... )-)+  deriving (Eq, Ord, Show, Typeable, Data)++data OpenTData sl =+    AtomTData String           -- text+  | SLinkTData sl              -- s(-( ... )-)+  deriving (Eq, Ord, Show, Typeable, Data)++newtype SData = SData { unSData :: OpenSData SLink TLink }+  deriving (Eq, Ord, Show, Typeable, Data)++newtype SLink = SLink { unSLink :: OpenLink SData SLink }+  deriving (Eq, Ord, Show, Typeable, Data)++newtype TData = TData { unTData :: OpenTData SLink }+  deriving (Eq, Ord, Show, Typeable, Data)++newtype TLink = TLink { unTLink :: OpenLink TData TLink }+  deriving (Eq, Ord, Show, Typeable, Data)++-- Anti ST-Data++data DualSData =+    PositiveDualSData (OpenSData DualSLink DualTLink)+  | AntiAtomDualSData AntiAtom+  deriving (Eq, Ord, Show, Typeable, Data)++data DualSLink =+    PositiveDualSLink (OpenLink DualSData DualSLink)+  | AntiConsDualSLink String+  deriving (Eq, Ord, Show, Typeable, Data)++data DualTData = DualTData { unDualTData :: OpenTData DualSLink }+  deriving (Eq, Ord, Show, Typeable, Data)++data DualTLink = DualTLink { unDualTLink :: OpenLink DualTData DualTLink }+  deriving (Eq, Ord, Show, Typeable, Data)++sdataToList :: SData -> [SData]+sdataToList (SData (SLinkSData slink)) = slinkToList slink+sdataToList other = error $ printf "cannot convert sdata to list: %s" (show other)++slinkToList :: SLink -> [SData]+slinkToList (SLink NullLink) = []+slinkToList (SLink (ConsLink s ss)) = s : slinkToList ss
+ src/Data/STData/Parse.hs view
@@ -0,0 +1,387 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.STData.Parse+  ( sexpSTDataTokenValueM , openStructureTokenValueM , closeStructureTokenValueM+  , openTextTokenValueM , closeTextTokenValueM , textTokenValueM+  , isDiscardSTDataToken+  , structureTokens , textTokens+  , lexStructure , lexText+  , parseSData, parseSLink+  , parseTData, parseTLink+  , convertOpenSDataE, convertOpenTDataE+  , convertOpenSDataP, convertOpenTDataP+  , sdata, slink+  , tdata, tlink+  ) where++import Control.Monad+import Data.SExp+import Data.STData.Data+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Parsec+import Text.Parsec.Pos+import Text.Parsec.String+import Text.Printf++data STDataToken =+    SExpSTDataToken SExpToken++  | OpenStructureToken+  | CloseStructureToken+  | OpenTextToken+  | CloseTextToken++  | TextToken String+  deriving (Eq, Ord, Show)++isDiscardSTDataToken :: STDataToken -> Bool+isDiscardSTDataToken (SExpSTDataToken t) = isDiscardSExpToken t+isDiscardSTDataToken _ = False++sexpSTDataTokenValueM :: STDataToken -> Maybe SExpToken+sexpSTDataTokenValueM t = case t of (SExpSTDataToken s) -> Just s ; _ -> Nothing+openStructureTokenValueM :: STDataToken -> Maybe ()+openStructureTokenValueM t = case t of OpenStructureToken -> Just () ; _ -> Nothing+closeStructureTokenValueM :: STDataToken -> Maybe ()+closeStructureTokenValueM t = case t of CloseStructureToken -> Just () ; _ -> Nothing+openTextTokenValueM :: STDataToken -> Maybe ()+openTextTokenValueM t = case t of OpenTextToken -> Just () ; _ -> Nothing+closeTextTokenValueM :: STDataToken -> Maybe ()+closeTextTokenValueM t = case t of CloseTextToken -> Just () ; _ -> Nothing+textTokenValueM :: STDataToken -> Maybe String+textTokenValueM t = case t of (TextToken s) -> Just s ; _ -> Nothing++structureTokens :: [Parser STDataToken]+structureTokens = +  [ string "t(-(" >> return OpenTextToken+  , string ")-)" >> return CloseStructureToken+  ] ++ liftM (liftM SExpSTDataToken) sexpTokens++textTokens :: [Parser STDataToken]+textTokens =+  [ string "s(-(" >> return OpenStructureToken+  , string ")-)" >> return CloseTextToken+  , let chunk :: Parser String+        chunk = msum+          [ do+              x <- noneOf "s)"+              liftM (x:) $ chunk+          , try possiblyBad+          , return ""+          ]+        possiblyBad :: Parser String+        possiblyBad = msum+          [ do+              x <- char 's'+              liftM (x:) $ chunkPostLetter+          , do+              x <- char ')'+              liftM (x:) $ chunkPostClose+          ]+        chunkPostLetter = msum+          [ do+              x <- noneOf "s)("+              liftM (x:) $ chunk+          , possiblyBad+          , do+              x <- char '('+              liftM (x:) $ chunkPostLetterOpen+          ]+        chunkPostLetterOpen = msum+          [ do+              x <- noneOf "s)-"+              liftM (x:) $ chunk+          , possiblyBad+          , do+              x <- char '-'+              liftM (x:) $ chunkPostLetterOpenDash+          ]+        chunkPostLetterOpenDash = msum+          [ do+              x <- noneOf "s)("+              liftM (x:) $ chunk+          , possiblyBad+          ]+        chunkPostClose = msum+          [ do+              x <- noneOf "s)-"+              liftM (x:) $ chunk+          , possiblyBad+          , do+              x <- char '-'+              liftM (x:) $ chunkPostCloseDash+          ]+        chunkPostCloseDash = msum+          [ do+              x <- noneOf "s)"+              liftM (x:) $ chunk+          , do+              x <- char 's'+              liftM (x:) $ chunkPostLetter+          ]+    in liftM TextToken chunk            +  ]++lexStructure :: String -> Either String [(SourcePos, STDataToken)]+lexStructure i = do+  (result, o, i') <- lexStructure' (initialPos "") i+  case i' of+    [] -> return $ filter (not . isDiscardSTDataToken . snd) result+    _ -> fail $ printf "did not consume all input: %s" (show o)++lexStructure' :: SourcePos -> String -> Either String ([(SourcePos, STDataToken)], SourcePos, String)+lexStructure' o [] = return ([], o, [])+lexStructure' o i = do+  (r@(_, t), o', i') <- lexOne o structureTokens i+  case t of+    OpenTextToken -> do+      (tsFlat, oFlat, iFlat) <- lexText' o' i'+      (tsTail, oTail, iTail) <- lexStructure' oFlat iFlat+      return (r : (tsFlat ++ tsTail), oTail, iTail)+    CloseStructureToken -> do+      return ([r], o', i')+    _ -> do+      (tsTail, oTail, iTail) <- lexStructure' o' i'+      return (r : tsTail, oTail, iTail)++lexText :: String -> Either String [(SourcePos, STDataToken)]+lexText i = do+  (result, o, i') <- lexText' (initialPos "") i+  case i' of+    [] -> return $ filter (not . isDiscardSTDataToken . snd) result+    _ -> fail $ printf "did not consume all input: %s" (show o)++lexText' :: SourcePos -> String -> Either String ([(SourcePos, STDataToken)], SourcePos, String)+lexText' o [] = return ([], o, [])+lexText' o i = do+  (r@(_, t), o', i') <- lexOne o textTokens i+  case t of+    OpenStructureToken -> do+      (tsLink, oLink, iLink) <- lexStructure' o' i'+      (tsTail, oTail, iTail) <- lexText' oLink iLink+      return (r : (tsLink ++ tsTail), oTail, iTail)+    CloseTextToken -> do+      return ([r], o', i')+    _ -> do+      (tsTail, oTail, iTail) <- lexText' o' i'+      return (r : tsTail, oTail, iTail)++-- Parsing++type STDataParser a = GenParser (SourcePos, STDataToken) () a++stDataTokenParser :: (STDataToken -> Maybe a) -> STDataParser a+stDataTokenParser f = token show fst (f . snd)++stringTok       :: STDataParser String  ; stringTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> stringTokenValueM+booleanTok      :: STDataParser Bool    ; booleanTok      = stDataTokenParser $ sexpSTDataTokenValueM >=> booleanTokenValueM+integerTok      :: STDataParser Integer ; integerTok      = stDataTokenParser $ sexpSTDataTokenValueM >=> integerTokenValueM+floatingTok     :: STDataParser Double  ; floatingTok     = stDataTokenParser $ sexpSTDataTokenValueM >=> floatingTokenValueM+symbolTok       :: STDataParser String  ; symbolTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> symbolTokenValueM+lParenTok       :: STDataParser ()      ; lParenTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> lParenTokenValueM+rParenTok       :: STDataParser ()      ; rParenTok       = stDataTokenParser $ sexpSTDataTokenValueM >=> rParenTokenValueM+antiConsTok     :: STDataParser ()      ; antiConsTok     = stDataTokenParser $ sexpSTDataTokenValueM >=> antiConsTokenValueM+antiValueTok    :: STDataParser String  ; antiValueTok    = stDataTokenParser $ sexpSTDataTokenValueM >=> antiValueTokenValueM+antiAtomTok     :: STDataParser String  ; antiAtomTok     = stDataTokenParser $ sexpSTDataTokenValueM >=> antiAtomTokenValueM+antiStringTok   :: STDataParser String  ; antiStringTok   = stDataTokenParser $ sexpSTDataTokenValueM >=> antiStringTokenValueM+antiBooleanTok  :: STDataParser String  ; antiBooleanTok  = stDataTokenParser $ sexpSTDataTokenValueM >=> antiBooleanTokenValueM+antiIntegerTok  :: STDataParser String  ; antiIntegerTok  = stDataTokenParser $ sexpSTDataTokenValueM >=> antiIntegerTokenValueM+antiFloatingTok :: STDataParser String  ; antiFloatingTok = stDataTokenParser $ sexpSTDataTokenValueM >=> antiFloatingTokenValueM+antiSymbolTok   :: STDataParser String  ; antiSymbolTok   = stDataTokenParser $ sexpSTDataTokenValueM >=> antiSymbolTokenValueM++openStructureTok  :: STDataParser ()     ; openStructureTok  = stDataTokenParser openStructureTokenValueM+closeStructureTok :: STDataParser ()     ; closeStructureTok = stDataTokenParser closeStructureTokenValueM+openTextTok       :: STDataParser ()     ; openTextTok       = stDataTokenParser openTextTokenValueM+closeTextTok      :: STDataParser ()     ; closeTextTok      = stDataTokenParser closeTextTokenValueM+textTok           :: STDataParser String ; textTok           = stDataTokenParser textTokenValueM++atomP :: STDataParser Atom+atomP = msum+  [ liftM StringAtom stringTok+  , liftM BooleanAtom booleanTok+  , liftM IntegerAtom integerTok+  , liftM FloatingAtom floatingTok+  , liftM SymbolAtom symbolTok+  ]++antiAtomP :: STDataParser AntiAtom+antiAtomP = msum+  [ liftM ValueAntiAtom antiValueTok+  , liftM AtomAntiAtom antiAtomTok+  , liftM StringAntiAtom antiStringTok+  , liftM BooleanAntiAtom antiBooleanTok+  , liftM IntegerAntiAtom antiIntegerTok+  , liftM FloatingAntiAtom antiFloatingTok+  , liftM SymbolAntiAtom antiSymbolTok+  ]++sdataP :: STDataParser SData+sdataP = msum+  [ liftM (SData . AtomSData) atomP+  , liftM (SData . SLinkSData) $ between lParenTok rParenTok slinkP+  , liftM (SData . TLinkSData) $ between openTextTok closeTextTok tlinkP+  ]++slinkP :: STDataParser SLink+slinkP = msum+  [ do+      s <- sdataP+      ss <- slinkP+      return . SLink $ ConsLink s ss+  , do+      return $ SLink NullLink+  ]++tdataP :: STDataParser TData+tdataP = msum+  [ liftM (TData . AtomTData) textTok+  , liftM (TData . SLinkTData) $ between openStructureTok closeStructureTok slinkP+  ]++tlinkP :: STDataParser TLink+tlinkP = msum+  [ do+      t <- tdataP+      ts <- tlinkP+      return . TLink $ ConsLink t ts+  , return $ TLink NullLink+  ]++dualSDataP :: STDataParser DualSData+dualSDataP = msum+  [ liftM (PositiveDualSData . AtomSData) atomP+  , liftM AntiAtomDualSData antiAtomP+  , liftM (PositiveDualSData . SLinkSData) $ between lParenTok rParenTok dualSLinkP+  , liftM (PositiveDualSData . TLinkSData) $ between openTextTok closeTextTok dualTLinkP+  ]++dualSLinkP :: STDataParser DualSLink+dualSLinkP = msum+  [ do +      s <- dualSDataP +      ss <- dualSLinkP +      return . PositiveDualSLink $ ConsLink s ss+  , do +      antiConsTok +      anti <- antiValueTok +      return $ AntiConsDualSLink anti+  , return $ PositiveDualSLink NullLink+  ]++dualTDataP :: STDataParser DualTData+dualTDataP = msum+  [ liftM (DualTData . AtomTData) textTok+  , liftM (DualTData . SLinkTData) $ between openStructureTok closeStructureTok dualSLinkP+  ]++dualTLinkP :: STDataParser DualTLink+dualTLinkP = msum+  [ do+      t <- dualTDataP+      ts <- dualTLinkP+      return . DualTLink $ ConsLink t ts+  , return $ DualTLink NullLink+  ]++parseSData :: String -> Either String SData+parseSData = tokParse lexStructure sdataP++parseSLink :: String -> Either String SLink+parseSLink = tokParse lexStructure slinkP++parseTData :: String -> Either String TData+parseTData = tokParse lexText tdataP++parseTLink :: String -> Either String TLink+parseTLink = tokParse lexText tlinkP++-- Quasi Quoting++convertOpenSDataE :: (sl -> Q Exp) -> (tl -> Q Exp) -> OpenSData sl tl -> Q Exp+convertOpenSDataE _ _ (AtomSData a) = conE 'AtomSData `appE` convertAtomE a+convertOpenSDataE csl _ (SLinkSData sl) = conE 'SLinkSData `appE` csl sl+convertOpenSDataE _ ctl (TLinkSData tl) = conE 'TLinkSData `appE` ctl tl++convertOpenTDataE :: (sl -> Q Exp) -> OpenTData sl -> Q Exp+convertOpenTDataE _ (AtomTData s) = conE 'AtomTData `appE` litE (stringL s)+convertOpenTDataE csl (SLinkTData sl) = conE 'SLinkTData `appE` csl sl++convertDualSDataToSDataE :: DualSData -> Q Exp+convertDualSDataToSDataE (PositiveDualSData p) = +  conE 'SData `appE` convertOpenSDataE convertDualSDataToSDataLinkE convertDualTDataToTDataLinkE p+convertDualSDataToSDataE (AntiAtomDualSData aa) = +  conE 'SData `appE` conE 'AtomSData `appE` convertAntiAtomToAtomE aa++convertDualSDataToSDataLinkE :: DualSLink -> Q Exp+convertDualSDataToSDataLinkE (PositiveDualSLink p) =+  conE 'SLink `appE` convertOpenLinkE convertDualSDataToSDataE convertDualSDataToSDataLinkE p+convertDualSDataToSDataLinkE (AntiConsDualSLink name) =+  conE 'SLink `appE` varE (mkName name)++convertDualTDataToTDataE :: DualTData -> Q Exp+convertDualTDataToTDataE (DualTData p) = +  conE 'TData `appE` convertOpenTDataE convertDualSDataToSDataLinkE p+convertDualTDataToTDataLinkE :: DualTLink -> Q Exp+convertDualTDataToTDataLinkE (DualTLink p) =+  conE 'TLink `appE` convertOpenLinkE convertDualTDataToTDataE convertDualTDataToTDataLinkE p++convertOpenSDataP :: (sl -> Q Pat) -> (tl -> Q Pat) -> OpenSData sl tl -> Q Pat+convertOpenSDataP _ _ (AtomSData a) = conP 'AtomSData [convertAtomP a]+convertOpenSDataP csl _ (SLinkSData sl) = conP 'SLinkSData [csl sl]+convertOpenSDataP _ ctl (TLinkSData tl) = conP 'TLinkSData [ctl tl]++convertOpenTDataP :: (sl -> Q Pat) -> OpenTData sl -> Q Pat+convertOpenTDataP _ (AtomTData s) = conP 'AtomTData [litP (stringL s)]+convertOpenTDataP csl (SLinkTData sl) = conP 'SLinkTData [csl sl]++convertDualSDataToSDataP :: DualSData -> Q Pat+convertDualSDataToSDataP (PositiveDualSData p) = +  conP 'SData [convertOpenSDataP convertDualSDataToSDataLinkP convertDualTDataToTDataLinkP p]+convertDualSDataToSDataP (AntiAtomDualSData aa) = +  conP 'SData [conP 'AtomSData [convertAntiAtomToAtomP aa]]++convertDualSDataToSDataLinkP :: DualSLink -> Q Pat+convertDualSDataToSDataLinkP (PositiveDualSLink p) =+  conP 'SLink [convertOpenLinkP convertDualSDataToSDataP convertDualSDataToSDataLinkP p]+convertDualSDataToSDataLinkP (AntiConsDualSLink name) =+  conP 'SLink [varP (mkName name)]++convertDualTDataToTDataP :: DualTData -> Q Pat+convertDualTDataToTDataP (DualTData p) = +  conP 'TData [convertOpenTDataP convertDualSDataToSDataLinkP p]+convertDualTDataToTDataLinkP :: DualTLink -> Q Pat+convertDualTDataToTDataLinkP (DualTLink p) =+  conP 'TLink [convertOpenLinkP convertDualTDataToTDataP convertDualTDataToTDataLinkP p]++sdata :: QuasiQuoter+sdata = QuasiQuoter +  { quoteExp = convertDualSDataToSDataE <=< qtokParse lexStructure dualSDataP+  , quotePat = convertDualSDataToSDataP <=< qtokParse lexStructure dualSDataP+  , quoteType = undefined+  , quoteDec = undefined+  }++slink :: QuasiQuoter+slink = QuasiQuoter +  { quoteExp = convertDualSDataToSDataLinkE <=< qtokParse lexStructure dualSLinkP+  , quotePat = convertDualSDataToSDataLinkP <=< qtokParse lexStructure dualSLinkP+  , quoteType = undefined+  , quoteDec = undefined+  }++tdata :: QuasiQuoter+tdata = QuasiQuoter +  { quoteExp = convertDualTDataToTDataE <=< qtokParse lexText dualTDataP+  , quotePat = convertDualTDataToTDataP <=< qtokParse lexText dualTDataP+  , quoteType = undefined+  , quoteDec = undefined+  }++tlink :: QuasiQuoter+tlink = QuasiQuoter +  { quoteExp = convertDualTDataToTDataLinkE <=< qtokParse lexText dualTLinkP+  , quotePat = convertDualTDataToTDataLinkP <=< qtokParse lexText dualTLinkP+  , quoteType = undefined+  , quoteDec = undefined+  }
+ stdata.cabal view
@@ -0,0 +1,25 @@+Name:                stdata+Version:             0.0.1+Synopsis:            Structure Data Library+Description:         Contains datatypes and quasi-quoting functionaly for+                     standard s-expressions and nested structured/unstructured data+License:             BSD3+License-file:        LICENSE+Author:              David Darais+Maintainer:          david.darais@gmail.com+-- Copyright:           +Stability:           Experimental+Category:            Data+Build-type:          Simple+Cabal-version:       >=1.6++Library+  Ghc-Options:         -Wall+  Hs-Source-Dirs:      src+  Exposed-modules:     Data.SExp, Data.SExp.Data, Data.SExp.Parse+                     , Data.STData, Data.STData.Data, Data.STData.Parse+  -- Other-modules:+  Build-depends:       base == 4.3.*+                     , syb == 0.3.*+                     , template-haskell == 2.5.*+                     , parsec == 3.1.*