module Data.STData.Parse
( STDataToken(..)
, 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 -> 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 -> return ([r], o', i')
_ -> do
(tsTail, oTail, iTail) <- lexText' o' i'
return (r : tsTail, oTail, iTail)
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
antiListTok :: STDataParser String ; antiListTok = stDataTokenParser $ sexpSTDataTokenValueM >=> antiListTokenValueM
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 ListAntiAtom antiListTok
, 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
, 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
msum [ do
anti <- antiValueTok
return $ AntiConsValueDualSLink anti
, do
anti <- antiListTok
return $ AntiConsListDualSLink 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
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) =
convertAntiAtomToValueE aa (\ x -> conE 'SData `appE` (conE 'AtomSData `appE` x))
(\ x -> varE 'listToSData `appE` x)
convertDualSDataToSDataLinkE :: DualSLink -> Q Exp
convertDualSDataToSDataLinkE (PositiveDualSLink p) =
conE 'SLink `appE` convertOpenLinkE convertDualSDataToSDataE convertDualSDataToSDataLinkE p
convertDualSDataToSDataLinkE (AntiConsValueDualSLink name) =
conE 'SLink `appE` varE (mkName name)
convertDualSDataToSDataLinkE (AntiConsListDualSLink name) =
varE 'listToSLink `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) =
convertAntiAtomToValueP aa (\ x -> conP 'SData [conP 'AtomSData [x]])
(\ x -> viewP (varE 'sdataToList) (conP 'Just [x]))
convertDualSDataToSDataLinkP :: DualSLink -> Q Pat
convertDualSDataToSDataLinkP (PositiveDualSLink p) =
conP 'SLink [convertOpenLinkP convertDualSDataToSDataP convertDualSDataToSDataLinkP p]
convertDualSDataToSDataLinkP (AntiConsValueDualSLink name) =
conP 'SLink [varP (mkName name)]
convertDualSDataToSDataLinkP (AntiConsListDualSLink name) =
viewP (varE 'slinkToList) (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
}