diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/src/Data/SExp.hs b/src/Data/SExp.hs new file mode 100644 --- /dev/null +++ b/src/Data/SExp.hs @@ -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))" diff --git a/src/Data/SExp/Data.hs b/src/Data/SExp/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/SExp/Data.hs @@ -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) + diff --git a/src/Data/SExp/Parse.hs b/src/Data/SExp/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/SExp/Parse.hs @@ -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 diff --git a/src/Data/STData.hs b/src/Data/STData.hs new file mode 100644 --- /dev/null +++ b/src/Data/STData.hs @@ -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))" + diff --git a/src/Data/STData/Data.hs b/src/Data/STData/Data.hs new file mode 100644 --- /dev/null +++ b/src/Data/STData/Data.hs @@ -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 diff --git a/src/Data/STData/Parse.hs b/src/Data/STData/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/STData/Parse.hs @@ -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 + } diff --git a/stdata.cabal b/stdata.cabal new file mode 100644 --- /dev/null +++ b/stdata.cabal @@ -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.*