module Burrito
( parse
, expand
, Template
, Value
, stringValue
, listValue
, dictionaryValue
)
where
import qualified Control.Applicative as Applicative
import qualified Control.Monad as Monad
import qualified Data.Bits as Bits
import qualified Data.Char as Char
import qualified Data.Functor.Identity as Identity
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Maybe as Maybe
import qualified Data.Word as Word
import qualified Text.Printf as Printf
parse :: String -> Maybe Template
parse string = case runParser parseTemplate string of
Just (template, "") -> Just template
_ -> Nothing
expand :: [(String, Value)] -> Template -> String
expand values = Identity.runIdentity
. expandTemplate (pure . flip lookup values . nameToString)
newtype Template = Template
{ template_tokens :: [Token]
} deriving (Eq, Show)
data Token
= Token_Expression Expression
| Token_Literal Literal
deriving (Eq, Show)
newtype Literal = Literal
{ literal_characters :: NonEmpty.NonEmpty Character
} deriving (Eq, Show)
data Character
= Character_Encoded Word.Word8
| Character_Unencoded Char
deriving (Eq, Show)
data Expression = Expression
{ expression_operator :: Operator
, expression_variables :: NonEmpty.NonEmpty Variable
} deriving (Eq, Show)
data Operator
= Operator_Ampersand
| Operator_FullStop
| Operator_None
| Operator_NumberSign
| Operator_PlusSign
| Operator_QuestionMark
| Operator_Semicolon
| Operator_Solidus
deriving (Eq, Show)
data Variable = Variable
{ variable_modifier :: Modifier
, variable_name :: Name
} deriving (Eq, Show)
data Modifier
= Modifier_Asterisk
| Modifier_Colon Int
| Modifier_None
deriving (Eq, Show)
newtype Name = Name
{ name_chars :: NonEmpty.NonEmpty Char
} deriving (Eq, Show)
data Value
= Value_Dictionary [(String, String)]
| Value_List [String]
| Value_String String
deriving (Eq, Show)
stringValue :: String -> Value
stringValue = Value_String
listValue :: [String] -> Value
listValue = Value_List
dictionaryValue :: [(String, String)] -> Value
dictionaryValue = Value_Dictionary
expandTemplate
:: Applicative m => (Name -> m (Maybe Value)) -> Template -> m String
expandTemplate f = expandTokens f . template_tokens
expandTokens
:: Applicative m => (Name -> m (Maybe Value)) -> [Token] -> m String
expandTokens f = fmap concat . traverse (expandToken f)
expandToken :: Applicative m => (Name -> m (Maybe Value)) -> Token -> m String
expandToken f token = case token of
Token_Literal literal -> pure $ expandLiteral literal
Token_Expression expression -> expandExpression f expression
expandLiteral :: Literal -> String
expandLiteral = concatMap expandCharacter . literal_characters
expandCharacter :: Character -> String
expandCharacter character = case character of
Character_Encoded word8 -> percentEncodeWord8 word8
Character_Unencoded char -> escapeChar Operator_PlusSign char
escapeChar :: Operator -> Char -> String
escapeChar operator char =
if isAllowed operator char then [char] else percentEncodeChar char
isAllowed :: Operator -> Char -> Bool
isAllowed operator char = case operator of
Operator_NumberSign -> isUnreserved char || isReserved char
Operator_PlusSign -> isUnreserved char || isReserved char
_ -> isUnreserved char
percentEncodeChar :: Char -> String
percentEncodeChar = concatMap percentEncodeWord8 . encodeUtf8
percentEncodeWord8 :: Word.Word8 -> String
percentEncodeWord8 = Printf.printf "%%%02X"
expandExpression
:: Applicative m => (Name -> m (Maybe Value)) -> Expression -> m String
expandExpression f expression =
let
operator = expression_operator expression
prefix = prefixFor operator
separator = separatorFor operator
finalize expansions =
(if null expansions then "" else prefix)
<> List.intercalate separator expansions
in fmap finalize . expandVariables f operator $ expression_variables
expression
prefixFor :: Operator -> String
prefixFor operator = case operator of
Operator_Ampersand -> "&"
Operator_FullStop -> "."
Operator_None -> ""
Operator_NumberSign -> "#"
Operator_PlusSign -> ""
Operator_QuestionMark -> "?"
Operator_Semicolon -> ";"
Operator_Solidus -> "/"
separatorFor :: Operator -> String
separatorFor operator = case operator of
Operator_Ampersand -> "&"
Operator_FullStop -> "."
Operator_None -> ","
Operator_NumberSign -> ","
Operator_PlusSign -> ","
Operator_QuestionMark -> "&"
Operator_Semicolon -> ";"
Operator_Solidus -> "/"
expandVariables
:: Applicative m
=> (Name -> m (Maybe Value))
-> Operator
-> NonEmpty.NonEmpty Variable
-> m [String]
expandVariables f operator =
fmap Maybe.catMaybes . traverse (expandVariable f operator) . NonEmpty.toList
expandVariable
:: Applicative m
=> (Name -> m (Maybe Value))
-> Operator
-> Variable
-> m (Maybe String)
expandVariable f operator variable =
let
name = variable_name variable
modifier = variable_modifier variable
in expandMaybeValue operator name modifier <$> f name
expandMaybeValue :: Operator -> Name -> Modifier -> Maybe Value -> Maybe String
expandMaybeValue operator name modifier maybeValue = do
value <- maybeValue
expandValue operator name modifier value
expandValue :: Operator -> Name -> Modifier -> Value -> Maybe String
expandValue operator name modifier value = case value of
Value_Dictionary dictionary ->
expandDictionary operator name modifier <$> NonEmpty.nonEmpty dictionary
Value_List list ->
expandList operator name modifier <$> NonEmpty.nonEmpty list
Value_String string -> Just $ expandString operator name modifier string
expandDictionary
:: Operator
-> Name
-> Modifier
-> NonEmpty.NonEmpty (String, String)
-> String
expandDictionary = expandElements
$ \operator _ modifier -> expandDictionaryElement operator modifier
expandDictionaryElement :: Operator -> Modifier -> (String, String) -> [String]
expandDictionaryElement operator modifier (name, value) =
let escape = escapeString operator Modifier_None
in
case modifier of
Modifier_Asterisk -> [escape name <> "=" <> escape value]
_ -> [escape name, escape value]
expandList
:: Operator -> Name -> Modifier -> NonEmpty.NonEmpty String -> String
expandList = expandElements $ \operator name modifier ->
pure . expandListElement operator name modifier
expandListElement :: Operator -> Name -> Modifier -> String -> String
expandListElement operator name modifier = case modifier of
Modifier_Asterisk -> expandString operator name Modifier_None
_ -> expandString Operator_None name Modifier_None
expandElements
:: (Operator -> Name -> Modifier -> a -> [String])
-> Operator
-> Name
-> Modifier
-> NonEmpty.NonEmpty a
-> String
expandElements f operator name modifier =
let
showPrefix = case modifier of
Modifier_Asterisk -> False
_ -> case operator of
Operator_Ampersand -> True
Operator_QuestionMark -> True
Operator_Semicolon -> True
_ -> False
prefix = if showPrefix then nameToString name <> "=" else ""
separator = case modifier of
Modifier_Asterisk -> separatorFor operator
_ -> ","
in mappend prefix . List.intercalate separator . concatMap
(f operator name modifier)
expandString :: Operator -> Name -> Modifier -> String -> String
expandString operator name modifier s =
let
prefix = case operator of
Operator_Ampersand -> nameToString name <> "="
Operator_QuestionMark -> nameToString name <> "="
Operator_Semicolon -> nameToString name <> if null s then "" else "="
_ -> ""
in prefix <> escapeString operator modifier s
escapeString :: Operator -> Modifier -> String -> String
escapeString operator modifier string =
concatMap (escapeChar operator) $ case modifier of
Modifier_Colon size -> take size string
_ -> string
nameToString :: Name -> String
nameToString = NonEmpty.toList . name_chars
encodeUtf8 :: Char -> [Word.Word8]
encodeUtf8 char =
let
oneByte x = [intToWord8 $ bitAnd 0x7f x]
twoBytes x =
[ bitOr 0xc0 . intToWord8 . bitAnd 0x3f $ bitShiftR 6 x
, bitOr 0x80 . intToWord8 $ bitAnd 0x3f x
]
threeBytes x =
[ bitOr 0xe0 . intToWord8 . bitAnd 0x0f $ bitShiftR 12 x
, bitOr 0x80 . intToWord8 . bitAnd 0x3f $ bitShiftR 6 x
, bitOr 0x80 . intToWord8 $ bitAnd 0x3f x
]
fourBytes x =
[ bitOr 0xf0 . intToWord8 . bitAnd 0x07 $ bitShiftR 18 x
, bitOr 0x80 . intToWord8 . bitAnd 0x3f $ bitShiftR 12 x
, bitOr 0x80 . intToWord8 . bitAnd 0x3f $ bitShiftR 6 x
, bitOr 0x80 . intToWord8 $ bitAnd 0x3f x
]
in case Char.ord char of
int
| int <= 0x7f -> oneByte int
| int <= 0x7ff -> twoBytes int
| int <= 0xffff -> threeBytes int
| otherwise -> fourBytes int
bitAnd :: Bits.Bits a => a -> a -> a
bitAnd = (Bits..&.)
bitOr :: Bits.Bits a => a -> a -> a
bitOr = (Bits..|.)
bitShiftR :: Bits.Bits a => Int -> a -> a
bitShiftR = flip Bits.shiftR
intToWord8 :: Int -> Word.Word8
intToWord8 x =
let
lo = word8ToInt (minBound :: Word.Word8)
hi = word8ToInt (maxBound :: Word.Word8)
in if x < lo
then error $ "intToWord8: " <> show x <> " < " <> show lo
else if x > hi
then error $ "intToWord8: " <> show x <> " > " <> show hi
else fromIntegral x
word8ToInt :: Word.Word8 -> Int
word8ToInt = fromIntegral
newtype Parser a = Parser
{ runParser :: String -> Maybe (a, String)
}
instance Functor Parser where
fmap f p = Parser $ \s -> case runParser p s of
Nothing -> Nothing
Just (x, t) -> Just (f x, t)
instance Applicative Parser where
pure x = Parser $ \s -> Just (x, s)
p <*> q = Parser $ \s -> case runParser p s of
Nothing -> Nothing
Just (f, t) -> case runParser q t of
Nothing -> Nothing
Just (x, u) -> Just (f x, u)
instance Monad Parser where
p >>= f = Parser $ \s -> case runParser p s of
Nothing -> Nothing
Just (x, t) -> runParser (f x) t
instance Applicative.Alternative Parser where
empty = Parser $ const Nothing
p <|> q = Parser $ \s -> case runParser p s of
Nothing -> runParser q s
Just (x, t) -> Just (x, t)
parseAny :: Parser Char
parseAny = Parser $ \string -> case string of
"" -> Nothing
first : rest -> Just (first, rest)
parseBetween :: Parser before -> Parser after -> Parser a -> Parser a
parseBetween before after parser = before *> parser <* after
parseChar :: Char -> Parser Char
parseChar = parseIf . (==)
parseChar_ :: Char -> Parser ()
parseChar_ = Monad.void . parseChar
parseEither :: Parser a -> Parser a -> Parser a
parseEither = (Applicative.<|>)
parseIf :: (Char -> Bool) -> Parser Char
parseIf predicate = do
char <- parseAny
if predicate char then pure char else Applicative.empty
parseNonEmpty :: Parser a -> Parser (NonEmpty.NonEmpty a)
parseNonEmpty parser = nonEmpty <$> parser <*> Applicative.many parser
parseSepBy1 :: Parser separator -> Parser a -> Parser (NonEmpty.NonEmpty a)
parseSepBy1 separator parser =
nonEmpty <$> parser <*> Applicative.many (separator *> parser)
parseTemplate :: Parser Template
parseTemplate = Template <$> Applicative.many parseToken
parseToken :: Parser Token
parseToken = parseEither
(Token_Literal <$> parseLiteral)
(Token_Expression <$> parseExpression)
parseLiteral :: Parser Literal
parseLiteral = Literal <$> parseNonEmpty parseCharacter
parseCharacter :: Parser Character
parseCharacter = parseEither parseCharacterUnencoded parseCharacterEncoded
parseCharacterUnencoded :: Parser Character
parseCharacterUnencoded = Character_Unencoded <$> parseIf isLiteral
parseCharacterEncoded :: Parser Character
parseCharacterEncoded = do
(hi, lo) <- parsePercentEncoded
pure . Character_Encoded $ intToWord8
(Char.digitToInt hi * 16 + Char.digitToInt lo)
parseExpression :: Parser Expression
parseExpression =
parseBetween (parseChar_ '{') (parseChar_ '}')
$ Expression
<$> parseOperator
<*> parseVariableList
parseVariableList :: Parser (NonEmpty.NonEmpty Variable)
parseVariableList = parseSepBy1 (parseChar_ ',') parseVarspec
parseVarspec :: Parser Variable
parseVarspec = do
name <- parseVarname
modifier <- parseModifier
pure $ Variable { variable_name = name, variable_modifier = modifier }
parseVarname :: Parser Name
parseVarname = do
first <- parseVarcharFirst
rest <- Applicative.many parseVarcharRest
pure . Name $ combine first rest
parseVarcharFirst :: Parser (NonEmpty.NonEmpty Char)
parseVarcharFirst = parseEither parseVarcharUnencoded parseVarcharEncoded
parseVarcharUnencoded :: Parser (NonEmpty.NonEmpty Char)
parseVarcharUnencoded = pure <$> parseIf isVarchar
parseVarcharEncoded :: Parser (NonEmpty.NonEmpty Char)
parseVarcharEncoded = do
(hi, lo) <- parsePercentEncoded
pure $ nonEmpty '%' [hi, lo]
parseVarcharRest :: Parser (NonEmpty.NonEmpty Char)
parseVarcharRest = parseEither
(nonEmpty <$> parseChar '.' <*> fmap NonEmpty.toList parseVarcharFirst)
parseVarcharFirst
isVarchar :: Char -> Bool
isVarchar x = case x of
'_' -> True
_ -> isAlpha x || Char.isDigit x
combine :: NonEmpty.NonEmpty a -> [NonEmpty.NonEmpty a] -> NonEmpty.NonEmpty a
combine xs =
nonEmpty (NonEmpty.head xs)
. mappend (NonEmpty.tail xs)
. concatMap NonEmpty.toList
nonEmpty :: a -> [a] -> NonEmpty.NonEmpty a
nonEmpty = (NonEmpty.:|)
parsePercentEncoded :: Parser (Char, Char)
parsePercentEncoded = do
parseChar_ '%'
(,) <$> parseIf Char.isHexDigit <*> parseIf Char.isHexDigit
parseOperator :: Parser Operator
parseOperator =
Maybe.fromMaybe Operator_None <$> Applicative.optional parseRequiredOperator
parseRequiredOperator :: Parser Operator
parseRequiredOperator = do
operator <- parseIf isOperator
maybe Applicative.empty pure $ toOperator operator
toOperator :: Char -> Maybe Operator
toOperator x = case x of
'+' -> Just Operator_PlusSign
'#' -> Just Operator_NumberSign
'.' -> Just Operator_FullStop
'/' -> Just Operator_Solidus
';' -> Just Operator_Semicolon
'?' -> Just Operator_QuestionMark
'&' -> Just Operator_Ampersand
_ -> Nothing
isOperator :: Char -> Bool
isOperator x = isOpLevel2 x || isOpLevel3 x || isOpReserve x
isOpLevel2 :: Char -> Bool
isOpLevel2 x = case x of
'+' -> True
'#' -> True
_ -> False
isOpLevel3 :: Char -> Bool
isOpLevel3 x = case x of
'.' -> True
'/' -> True
';' -> True
'?' -> True
'&' -> True
_ -> False
isOpReserve :: Char -> Bool
isOpReserve x = case x of
'=' -> True
',' -> True
'!' -> True
'@' -> True
'|' -> True
_ -> False
parseModifier :: Parser Modifier
parseModifier =
fmap (Maybe.fromMaybe Modifier_None) . Applicative.optional $ parseEither
parsePrefixModifier
parseExplodeModifier
parsePrefixModifier :: Parser Modifier
parsePrefixModifier = do
parseChar_ ':'
Modifier_Colon <$> parseMaxLength
parseMaxLength :: Parser Int
parseMaxLength = do
first <- parseNonZeroDigit
rest <- parseUpTo 3 parseDigit
pure . fromDigits $ nonEmpty first rest
fromDigits :: NonEmpty.NonEmpty Int -> Int
fromDigits = foldr1 ((+) . (10 *))
parseUpTo :: Int -> Parser a -> Parser [a]
parseUpTo = parseUpToWith []
parseUpToWith :: [a] -> Int -> Parser a -> Parser [a]
parseUpToWith accumulator remaining parser = if remaining < 1
then pure accumulator
else do
result <- Applicative.optional parser
case result of
Nothing -> pure accumulator
Just value -> parseUpToWith (value : accumulator) (remaining - 1) parser
parseNonZeroDigit :: Parser Int
parseNonZeroDigit = Char.digitToInt <$> parseIf isNonZeroDigit
isNonZeroDigit :: Char -> Bool
isNonZeroDigit x = case x of
'0' -> False
_ -> Char.isDigit x
parseDigit :: Parser Int
parseDigit = Char.digitToInt <$> parseIf Char.isDigit
isAlpha :: Char -> Bool
isAlpha x = Char.isAsciiUpper x || Char.isAsciiLower x
parseExplodeModifier :: Parser Modifier
parseExplodeModifier = Modifier_Asterisk <$ parseChar_ '*'
isReserved :: Char -> Bool
isReserved x = isGenDelim x || isSubDelim x
isGenDelim :: Char -> Bool
isGenDelim x = case x of
':' -> True
'/' -> True
'?' -> True
'#' -> True
'[' -> True
']' -> True
'@' -> True
_ -> False
isSubDelim :: Char -> Bool
isSubDelim x = case x of
'!' -> True
'$' -> True
'&' -> True
'\'' -> True
'(' -> True
')' -> True
'*' -> True
'+' -> True
',' -> True
';' -> True
'=' -> True
_ -> False
isUnreserved :: Char -> Bool
isUnreserved x = case x of
'-' -> True
'.' -> True
'_' -> True
'~' -> True
_ -> isAlpha x || Char.isDigit x
isLiteral :: Char -> Bool
isLiteral x = case x of
' ' -> False
'"' -> False
'\'' -> False
'%' -> False
'<' -> False
'>' -> False
'\\' -> False
'^' -> False
'`' -> False
'{' -> False
'|' -> False
'}' -> False
_ -> between '\x20' '\x7e' x || isUcschar x || isIprivate x
isUcschar :: Char -> Bool
isUcschar x =
between '\xa0' '\xd7ff' x
|| between '\xf900' '\xfdcf' x
|| between '\xfdf0' '\xffef' x
|| between '\x10000' '\x1fffd' x
|| between '\x20000' '\x2fffd' x
|| between '\x30000' '\x3fffd' x
|| between '\x40000' '\x4fffd' x
|| between '\x50000' '\x5fffd' x
|| between '\x60000' '\x6fffd' x
|| between '\x70000' '\x7fffd' x
|| between '\x80000' '\x8fffd' x
|| between '\x90000' '\x9fffd' x
|| between '\xa0000' '\xafffd' x
|| between '\xb0000' '\xbfffd' x
|| between '\xc0000' '\xcfffd' x
|| between '\xd0000' '\xdfffd' x
|| between '\xe1000' '\xefffd' x
isIprivate :: Char -> Bool
isIprivate x =
between '\xe000' '\xf8ff' x
|| between '\xf0000' '\xffffd' x
|| between '\x100000' '\x10fffd' x
between
:: Ord a
=> a
-> a
-> a
-> Bool
between lo hi x = lo <= x && x <= hi