llsd-0.1.0.1: Network/Format/LLSD/LLIDL.hs
{-# LANGUAGE DeriveDataTypeable #-}
-- |
-- Module : Network.Format.LLSD.LLIDL
-- Copyright : (c) Linden Lab 2009
-- License : MIT
-- Maintainer : bos@lindenlab.com
-- Stability : provisional
-- Portability : portable
module Network.Format.LLSD.LLIDL (
LLIDL(..),
match, valid, hasAdditional, hasDefaulted, incompatible,
Suite(),
request, response,
Definition(..), -- for quasi quoter
fromDefinitions,
parseValue,
parseSuite,
llidlSuite,
llidlValue,
)
where
import Control.Monad
import Data.Data
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Network.Format.LLSD.Conversion
import Network.Format.LLSD.Internal
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
import qualified Data.ByteString.Lazy as Byte
import qualified Data.Time as Time
import qualified Data.UUID as UUID
import qualified Network.URI as URI
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
data LLIDL = UndefLLIDL
| BoolLLIDL | IntLLIDL | RealLLIDL | StringLLIDL
| DateLLIDL | UriLLIDL | UuidLLIDL | BinaryLLIDL
| SelectNameLLIDL String | SelectBoolLLIDL Bool | SelectIntLLIDL Int
| ArrayLLIDL Bool [LLIDL]
| MapLLIDL [(String, LLIDL)]
| DictLLIDL LLIDL
| VariantLLIDL String
| UndefinedLLIDL
| BoundLLIDL VarContext LLIDL
deriving (Typeable, Data)
baseResolve :: LLIDL -> LLSD -> Fidelity
baseResolve i = resolve i M.empty
match :: LLIDL -> LLSD -> Bool
match i v = baseResolve i v >= Converted
valid :: LLIDL -> LLSD -> Bool
valid i v = baseResolve i v >= Mixed
hasAdditional :: LLIDL -> LLSD -> Bool
hasAdditional i v = let r = baseResolve i v in r == Additional || r == Mixed
hasDefaulted :: LLIDL -> LLSD -> Bool
hasDefaulted i v = let r = baseResolve i v in r == Defaulted || r == Mixed
incompatible :: LLIDL -> LLSD -> Bool
incompatible i v = baseResolve i v < Mixed
type VarContext = M.Map String [LLIDL]
bindContext :: VarContext -> LLIDL -> LLIDL
bindContext = BoundLLIDL
type ReqRsp = (LLIDL, LLIDL)
data Definition = Resource String LLIDL LLIDL | Variant String LLIDL
deriving (Typeable, Data)
data Suite = S {
resources :: M.Map String ReqRsp,
variants :: VarContext
}
fromDefinitions :: [Definition] -> Suite
fromDefinitions = foldl' merge (S M.empty M.empty)
where merge (S rs vs) (Resource k req rsp) = S (M.insert k (req, rsp) rs) vs
merge (S rs vs) (Variant k var) = S rs (M.insertWith (++) k [var] vs)
resource :: String -> Suite -> ReqRsp
resource r st = M.findWithDefault undefinedResource r (resources st)
where undefinedResource = (UndefinedLLIDL, UndefinedLLIDL)
request :: String -> Suite -> LLIDL
request r st = bindContext (variants st) (fst $ resource r st)
response :: String -> Suite -> LLIDL
response r st = bindContext (variants st) (snd $ resource r st)
type Resolver = VarContext -> LLSD -> Fidelity
resolve :: LLIDL -> Resolver
resolve UndefLLIDL = resolveTo Matched
resolve BoolLLIDL = resolveType (undefined :: Bool)
resolve IntLLIDL = resolveType (undefined :: Int)
resolve RealLLIDL = resolveType (undefined :: Double)
resolve StringLLIDL = resolveType (undefined :: String)
resolve DateLLIDL = resolveType (undefined :: Time.UTCTime)
resolve UriLLIDL = resolveType (undefined :: URI.URI)
resolve UuidLLIDL = resolveType (undefined :: UUID.UUID)
resolve BinaryLLIDL = resolveType (undefined :: Byte.ByteString)
resolve (SelectNameLLIDL v) = resolveSelect v
resolve (SelectBoolLLIDL v) = resolveSelect v
resolve (SelectIntLLIDL v) = resolveSelect v
resolve (ArrayLLIDL repeating is) = resolveArray repeating is
resolve (MapLLIDL assocs) = resolveMap assocs
resolve (DictLLIDL i) = resolveDict i
resolve (VariantLLIDL v) = resolveVariant v
resolve UndefinedLLIDL = resolveTo Incompatible
resolve (BoundLLIDL c i) = \_ l -> resolve i c l
resolveTo :: Fidelity -> Resolver
resolveTo f _ _ = f
resolveType :: (ConvertTo a) => a -> Resolver
resolveType t _ l = snd $ convertAs t
where convertAs :: (ConvertTo a) => a -> Conversion a
convertAs _ = conversionFromLLSD l
resolveSelect :: (Eq a, ConvertTo a) => a -> Resolver
resolveSelect v _ l = select (conversionFromLLSD l)
where select c = if v == fst c then snd c else Incompatible
resolveArray :: Bool -> [LLIDL] -> Resolver
resolveArray repeating is = arrayMatch
where arrayMatch _ (LUndef) = Defaulted
arrayMatch c v@(LArray _) = resolveAll c is0 $ toList v
arrayMatch _ _ = Incompatible
is0 = if repeating then [] else is
resolveAll c (j:js) (l:ls) = resolve j c l ~&~ resolveAll c js ls
resolveAll c (j:js) [] = resolve j c undef ~&~ resolveAll c js []
resolveAll c [] ls@(_:_) = if repeating
then resolveAll c is ls
else Additional
resolveAll _ [] [] = Matched
resolveMap :: [(String, LLIDL)] -> Resolver
resolveMap assocs = mapMatch
where mapMatch _ (LUndef) = Defaulted
mapMatch c (LMap m) = resolveAll ~&~ hasAll
where resolveAll = foldr (\a r -> resolveOne a ~&~ r) Matched assocs
resolveOne (k, l) = maybe Defaulted (resolve l c) $ M.lookup k m
hasAll = if M.keysSet m `S.isSubsetOf` idlkeys
then Matched
else Additional
mapMatch _ _ = Incompatible
idlkeys = S.fromList $ map fst assocs
resolveDict :: LLIDL -> Resolver
resolveDict i = dictMatch
where dictMatch _ (LUndef) = Defaulted
dictMatch c (LMap m) = M.fold (\l r -> resolve i c l ~&~ r) Matched m
dictMatch _ _ = Incompatible
resolveVariant :: String -> Resolver
resolveVariant v = varMatch
where varMatch c l = foldl' pRes Incompatible vars
where pRes r i = resolve i c l ~|~ r
vars = M.findWithDefault [] v c
showAnyError :: Either ParseError a -> Either String a
showAnyError = either (Left . show) (Right)
parseValue :: String -> Either String LLIDL
parseValue = showAnyError . parse (between s eof value) ""
parseSuite :: String -> Either String Suite
parseSuite = showAnyError . parse (between s eof suite) ""
value :: Parser LLIDL
value = simpleType <|> arrayType <|> mapType <|> selector <|> variant
simpleType :: Parser LLIDL
simpleType = typeSymbol "undef" UndefLLIDL
<|> typeSymbol "string" StringLLIDL
<|> typeSymbol "bool" BoolLLIDL
<|> typeSymbol "int" IntLLIDL
<|> typeSymbol "real" RealLLIDL
<|> typeSymbol "date" DateLLIDL
<|> typeSymbol "uri" UriLLIDL
<|> typeSymbol "uuid" UuidLLIDL
<|> typeSymbol "binary" BinaryLLIDL
where typeSymbol t i = symbol t >> return i
arrayType :: Parser LLIDL
arrayType =
try (do { cymbol '['; is <- valueList; cymbol ']'; return $ ArrayLLIDL False is })
<|> (do { cymbol '['; is <- valueList; symbol "..."; cymbol ']'; return $ ArrayLLIDL True is })
valueList :: Parser [LLIDL]
valueList = sepEndBy1 value (cymbol ',')
mapType :: Parser LLIDL
mapType = try (simpleMapType) <|> try (dictMapType)
simpleMapType :: Parser LLIDL
simpleMapType = do
cymbol '{'; is <- memberList; cymbol '}'
let keys = map fst is
dupes = keys \\ nub keys
if null dupes
then return $ MapLLIDL is
else fail $ "duplicate map keys: " ++ intercalate ", " dupes
memberList :: Parser [(String, LLIDL)]
memberList = sepEndBy1 member (cymbol ',')
member :: Parser (String, LLIDL)
member = do { n <- name; cymbol ':'; v <- value; return (n, v) }
dictMapType :: Parser LLIDL
dictMapType = do
cymbol '{'; cymbol '$'; cymbol ':'; i <- value; cymbol '}'
return $ DictLLIDL i
selector :: Parser LLIDL
selector =
try (lexeme $ between (char '"') (char '"') name' >>= return . SelectNameLLIDL)
<|> (symbol "true" >> return (SelectBoolLLIDL True))
<|> (symbol "false" >> return (SelectBoolLLIDL False))
<|> ((lexeme $ integer) >>= return . SelectIntLLIDL)
variant :: Parser LLIDL
variant = char '&' >> name >>= return . VariantLLIDL
suite :: Parser Suite
suite = definitions >>= return . fromDefinitions
definitions :: Parser [Definition]
definitions = many ( variantDef <|> resourceDef )
variantDef :: Parser Definition
variantDef = return Variant `ap` between (char '&') (cymbol '=') name `ap` value
resourceDef :: Parser Definition
resourceDef = do
res <- resName
(req, resp) <- (postRes <|> getRes <|> getPutRes)
return $ Resource res req resp
resName :: Parser String
resName = symbol "%%" >> name
postRes :: Parser (LLIDL, LLIDL)
postRes = do
req <- symbol "->" >> value
resp <- symbol "<-" >> value
return (req, resp)
getRes :: Parser (LLIDL, LLIDL)
getRes = do
body <- symbol "<<" >> value
return (UndefinedLLIDL, body)
getPutRes :: Parser (LLIDL, LLIDL)
getPutRes = do
body <- (symbol "<>" <|> symbol "<x>") >> value
return (body, body)
-- These follow the pattern in Parsec.Token, but we redo it here because the
-- specifics of whitepsace in LLIDL don't match the assumptions in Parsec.Token.
symbol :: String -> Parser ()
symbol t = try (lexeme $ string t >> return ())
cymbol :: Char -> Parser ()
cymbol c = lexeme $ char c >> return ()
name :: Parser String
name = lexeme name'
lexeme :: Parser a -> Parser a
lexeme p = do { r <- p; s; return r }
-- Non-lexmeme parsers
s :: Parser ()
s = skipMany (tab <|> newline <|> space <|> comment)
-- unfortunate name, but that is what it is called in the Internet Draft
comment :: Parser Char
comment = char ';' >> (skipMany $ noneOf "\n") >> newline >> return ';'
--FIXME: newline in spec is \n, \r, or \r\n
--FIXME: returning Char is ugly just to make s easier
name' :: Parser String
name' = do { c <- nameStart; cs <- many nameContinue; return (c:cs) }
where nameStart = idStart <|> char '_'
nameContinue = idContinue <|> char '_' <|> char '/'
idStart = oneOf ['A'..'Z'] <|> oneOf ['a'..'z']
idContinue = idStart <|> oneOf ['0'..'9']
integer :: Parser Int
integer = many1 digit >>= return . read
--
-- QuasiQuote Support
--
llidlSuite, llidlValue :: QuasiQuoter
llidlSuite = QuasiQuoter (qqToSuite $ qq definitions) failPat
llidlValue = QuasiQuoter (qq value) failPat
qq :: (Data t) => (Parser t) -> String -> TH.Q TH.Exp
qq pThing input = do
loc <- TH.location
let pos = newPos (TH.loc_filename loc)
(fst (TH.loc_start loc))
(snd (TH.loc_start loc))
case parse (setPosition pos >> between s eof pThing) "" input of
Left err -> fail $ show err
Right e -> dataToExpQ (const Nothing) e
qqToSuite :: (String -> TH.Q TH.Exp) -> (String -> TH.Q TH.Exp)
qqToSuite f = \input -> do
eDefs <- f input
return $ TH.AppE (TH.VarE (TH.mkName "fromDefinitions")) eDefs
failPat :: String -> TH.Q TH.Pat
failPat _ = fail "can't pattern match llidl"