diff --git a/src/Data/SExp.hs b/src/Data/SExp.hs --- a/src/Data/SExp.hs +++ b/src/Data/SExp.hs @@ -5,6 +5,3 @@ 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 --- a/src/Data/SExp/Data.hs +++ b/src/Data/SExp/Data.hs @@ -20,12 +20,26 @@ deriving (Eq, Ord, Show, Typeable, Data) data AntiAtom = + -- | Created with QuasiQuotes of form @[sexp| \@:name |]@. Will be converted + -- to expression or pattern of type 'SExp'. ValueAntiAtom String + -- | Created with QuasiQuotes of form @[sexp| \@atom:name |]@. Will be + -- converted to expression or pattern of type 'Atom'. | AtomAntiAtom String + -- | Created with QuasiQuotes of form @[sexp| \@str:name |]@. Will be + -- converted to expression or pattern of type 'Atom'. | StringAntiAtom String + -- | Created with QuasiQuotes of form @[sexp| \@bool:name |]@. Will be + -- converted to expression or pattern of type 'Atom'. | BooleanAntiAtom String + -- | Created with QuasiQuotes of form @[sexp| \@int:name |]@. Will be + -- converted to expression or pattern of type 'Atom'. | IntegerAntiAtom String + -- | Created with QuasiQuotes of form @[sexp| \@float:name |]@. Will be + -- converted to expression or pattern of type 'Atom'. | FloatingAntiAtom String + -- | Created with QuasiQuotes of form @[sexp| \@sym:name |]@. Will be + -- converted to expression or pattern of type 'Atom'. | SymbolAntiAtom String deriving (Eq, Ord, Show, Typeable, Data) diff --git a/src/Data/SExp/Parse.hs b/src/Data/SExp/Parse.hs --- a/src/Data/SExp/Parse.hs +++ b/src/Data/SExp/Parse.hs @@ -11,9 +11,9 @@ , sexpTokens , lexSExp , parseSExp, parseDualSExp - , convertAtomE, convertAntiAtomToAtomE + , convertAtomE, convertAntiAtomToValueE , convertOpenLinkE - , convertAtomP, convertAntiAtomToAtomP + , convertAtomP, convertAntiAtomToValueP , convertOpenLinkP , sexp, sexpl , lexOne, tokParse, qtokParse @@ -163,11 +163,11 @@ , 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 + , string "@str:" >> liftM AntiStringToken antiName + , string "@bool:" >> liftM AntiBooleanToken antiName + , string "@int:" >> liftM AntiIntegerToken antiName + , string "@float:" >> liftM AntiFloatingToken antiName + , string "@sym:" >> liftM AntiSymbolToken antiName ] where antiName = do @@ -283,17 +283,14 @@ 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 +convertAntiAtomToValueE :: AntiAtom -> (Q Exp -> Q Exp) -> Q Exp +convertAntiAtomToValueE (ValueAntiAtom name) _ = varE $ mkName name +convertAntiAtomToValueE (AtomAntiAtom name) qatom = qatom . varE $ mkName name +convertAntiAtomToValueE (StringAntiAtom name) qatom = qatom $ conE 'StringAtom `appE` varE (mkName name) +convertAntiAtomToValueE (BooleanAntiAtom name) qatom = qatom $ conE 'BooleanAtom `appE` varE (mkName name) +convertAntiAtomToValueE (IntegerAntiAtom name) qatom = qatom $ conE 'IntegerAtom `appE` varE (mkName name) +convertAntiAtomToValueE (FloatingAntiAtom name) qatom = qatom $ conE 'FloatingAtom `appE` varE (mkName name) +convertAntiAtomToValueE (SymbolAntiAtom name) qatom = qatom $ conE 'SymbolAtom `appE` varE (mkName name) convertOpenSExpE :: (l -> Q Exp) -> OpenSExp l -> Q Exp convertOpenSExpE _ (AtomSExp a) = conE 'AtomSExp `appE` convertAtomE a @@ -307,7 +304,7 @@ convertDualSExpToSExpE (PositiveDualSExp p) = conE 'SExp `appE` convertOpenSExpE convertDualSExpToSExpLinkE p convertDualSExpToSExpE (AntiAtomDualSExp aa) = - conE 'SExp `appE` conE 'AtomSExp `appE` convertAntiAtomToAtomE aa + convertAntiAtomToValueE aa $ \ x -> conE 'SExp `appE` (conE 'AtomSExp `appE` x) convertDualSExpToSExpLinkE :: DualSExpLink -> Q Exp convertDualSExpToSExpLinkE (PositiveDualSExpLink p) = @@ -323,26 +320,21 @@ 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] +convertAntiAtomToValueP :: AntiAtom -> (Q Pat -> Q Pat) -> Q Pat +convertAntiAtomToValueP (ValueAntiAtom "_") _ = wildP +convertAntiAtomToValueP (ValueAntiAtom name) _ = varP $ mkName name +convertAntiAtomToValueP (AtomAntiAtom "_") qatom = qatom wildP +convertAntiAtomToValueP (AtomAntiAtom name) qatom = qatom . varP $ mkName name +convertAntiAtomToValueP (StringAntiAtom "_") qatom = qatom $ conP 'StringAtom [wildP] +convertAntiAtomToValueP (StringAntiAtom name) qatom = qatom $ conP 'StringAtom [varP $ mkName name] +convertAntiAtomToValueP (BooleanAntiAtom "_") qatom = qatom $ conP 'BooleanAtom [wildP] +convertAntiAtomToValueP (BooleanAntiAtom name) qatom = qatom $ conP 'BooleanAtom [varP $ mkName name] +convertAntiAtomToValueP (IntegerAntiAtom "_") qatom = qatom $ conP 'IntegerAtom [wildP] +convertAntiAtomToValueP (IntegerAntiAtom name) qatom = qatom $ conP 'IntegerAtom [varP $ mkName name] +convertAntiAtomToValueP (FloatingAntiAtom "_") qatom = qatom $ conP 'FloatingAtom [wildP] +convertAntiAtomToValueP (FloatingAntiAtom name) qatom = qatom $ conP 'FloatingAtom [varP $ mkName name] +convertAntiAtomToValueP (SymbolAntiAtom "_") qatom = qatom $ conP 'SymbolAtom [wildP] +convertAntiAtomToValueP (SymbolAntiAtom name) qatom = qatom $ conP 'SymbolAtom [varP $ mkName name] convertOpenSExpP :: (l -> Q Pat) -> OpenSExp l -> Q Pat convertOpenSExpP _ (AtomSExp a) = conP 'AtomSExp [convertAtomP a] @@ -356,7 +348,7 @@ convertDualSExpToSExpP (PositiveDualSExp p) = conP 'SExp [convertOpenSExpP convertDualSExpToSExpLinkP p] convertDualSExpToSExpP (AntiAtomDualSExp aa) = - conP 'SExp [conP 'AtomSExp [convertAntiAtomToAtomP aa]] + convertAntiAtomToValueP aa $ \ x -> conP 'SExp [conP 'AtomSExp [x]] convertDualSExpToSExpLinkP :: DualSExpLink -> Q Pat convertDualSExpToSExpLinkP (PositiveDualSExpLink p) = diff --git a/src/Data/STData.hs b/src/Data/STData.hs --- a/src/Data/STData.hs +++ b/src/Data/STData.hs @@ -6,6 +6,3 @@ 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/Parse.hs b/src/Data/STData/Parse.hs --- a/src/Data/STData/Parse.hs +++ b/src/Data/STData/Parse.hs @@ -1,7 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} module Data.STData.Parse - ( sexpSTDataTokenValueM , openStructureTokenValueM , closeStructureTokenValueM + ( STDataToken(..) + , sexpSTDataTokenValueM , openStructureTokenValueM , closeStructureTokenValueM , openTextTokenValueM , closeTextTokenValueM , textTokenValueM , isDiscardSTDataToken , structureTokens , textTokens @@ -66,7 +67,7 @@ chunk = msum [ do x <- noneOf "s)" - liftM (x:) $ chunk + liftM (x:) chunk , try possiblyBad , return "" ] @@ -74,51 +75,51 @@ possiblyBad = msum [ do x <- char 's' - liftM (x:) $ chunkPostLetter + liftM (x:) chunkPostLetter , do x <- char ')' - liftM (x:) $ chunkPostClose + liftM (x:) chunkPostClose ] chunkPostLetter = msum [ do x <- noneOf "s)(" - liftM (x:) $ chunk + liftM (x:) chunk , possiblyBad , do x <- char '(' - liftM (x:) $ chunkPostLetterOpen + liftM (x:) chunkPostLetterOpen ] chunkPostLetterOpen = msum [ do x <- noneOf "s)-" - liftM (x:) $ chunk + liftM (x:) chunk , possiblyBad , do x <- char '-' - liftM (x:) $ chunkPostLetterOpenDash + liftM (x:) chunkPostLetterOpenDash ] chunkPostLetterOpenDash = msum [ do x <- noneOf "s)(" - liftM (x:) $ chunk + liftM (x:) chunk , possiblyBad ] chunkPostClose = msum [ do x <- noneOf "s)-" - liftM (x:) $ chunk + liftM (x:) chunk , possiblyBad , do x <- char '-' - liftM (x:) $ chunkPostCloseDash + liftM (x:) chunkPostCloseDash ] chunkPostCloseDash = msum [ do x <- noneOf "s)" - liftM (x:) $ chunk + liftM (x:) chunk , do x <- char 's' - liftM (x:) $ chunkPostLetter + liftM (x:) chunkPostLetter ] in liftM TextToken chunk ] @@ -139,8 +140,7 @@ (tsFlat, oFlat, iFlat) <- lexText' o' i' (tsTail, oTail, iTail) <- lexStructure' oFlat iFlat return (r : (tsFlat ++ tsTail), oTail, iTail) - CloseStructureToken -> do - return ([r], o', i') + CloseStructureToken -> return ([r], o', i') _ -> do (tsTail, oTail, iTail) <- lexStructure' o' i' return (r : tsTail, oTail, iTail) @@ -161,8 +161,7 @@ (tsLink, oLink, iLink) <- lexStructure' o' i' (tsTail, oTail, iTail) <- lexText' oLink iLink return (r : (tsLink ++ tsTail), oTail, iTail) - CloseTextToken -> do - return ([r], o', i') + CloseTextToken -> return ([r], o', i') _ -> do (tsTail, oTail, iTail) <- lexText' o' i' return (r : tsTail, oTail, iTail) @@ -229,8 +228,7 @@ s <- sdataP ss <- slinkP return . SLink $ ConsLink s ss - , do - return $ SLink NullLink + , return $ SLink NullLink ] tdataP :: STDataParser TData @@ -311,7 +309,7 @@ convertDualSDataToSDataE (PositiveDualSData p) = conE 'SData `appE` convertOpenSDataE convertDualSDataToSDataLinkE convertDualTDataToTDataLinkE p convertDualSDataToSDataE (AntiAtomDualSData aa) = - conE 'SData `appE` conE 'AtomSData `appE` convertAntiAtomToAtomE aa + convertAntiAtomToValueE aa $ \ x -> conE 'SData `appE` (conE 'AtomSData `appE` x) convertDualSDataToSDataLinkE :: DualSLink -> Q Exp convertDualSDataToSDataLinkE (PositiveDualSLink p) = @@ -339,7 +337,7 @@ convertDualSDataToSDataP (PositiveDualSData p) = conP 'SData [convertOpenSDataP convertDualSDataToSDataLinkP convertDualTDataToTDataLinkP p] convertDualSDataToSDataP (AntiAtomDualSData aa) = - conP 'SData [conP 'AtomSData [convertAntiAtomToAtomP aa]] + convertAntiAtomToValueP aa $ \ x -> conP 'SData [conP 'AtomSData [x]] convertDualSDataToSDataLinkP :: DualSLink -> Q Pat convertDualSDataToSDataLinkP (PositiveDualSLink p) = diff --git a/stdata.cabal b/stdata.cabal --- a/stdata.cabal +++ b/stdata.cabal @@ -1,5 +1,5 @@ Name: stdata -Version: 0.0.2 +Version: 0.0.3 Synopsis: Structure Data Library Description: Contains datatypes and quasi-quoting functionaly for standard s-expressions and nested structured/unstructured data