module Text.HPaco.Readers.Paco
( readPaco
)
where
import Control.Monad
import Control.Monad.IO.Class
import Text.HPaco.Reader
import Text.HPaco.AST.AST
import Text.HPaco.AST.Statement
import Text.HPaco.AST.Expression
import Text.Parsec.Prim
import Text.Parsec.Char
import Text.Parsec.Combinator
import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn)
import Text.Parsec.String hiding (Parser)
import Text.Parsec.Error (ParseError)
import Control.Exception (throw, Exception)
import Data.Typeable
import System.IO (withFile, IOMode (ReadMode))
import System.IO.Strict
import System.FilePath
instance Exception ParseError
deriving instance Typeable ParseError
data PacoState = PacoState
{ psBasePath :: FilePath
, psDefs :: [(String, Statement)]
, psIncludeExtension :: Maybe String
}
type Parser a = ParsecT String PacoState IO a
defaultPacoState :: PacoState
defaultPacoState = PacoState
{ psBasePath = ""
, psDefs = []
, psIncludeExtension = Nothing
}
readPaco :: Reader
readPaco filename =
let pstate = defaultPacoState
{ psBasePath = takeDirectory filename
, psIncludeExtension = renull $ takeExtension filename
}
in readPacoWithState pstate filename
where renull "" = Nothing
renull x = Just x
readPacoWithState :: PacoState -> Reader
readPacoWithState pstate filename src = do
result <- runParserT document pstate filename src
either
throw
return
result
document :: Parser AST
document = do
stmts <- many statement
eof
pstate <- getState
return $ AST
{ astRootStatement = StatementSequence stmts
, astDefs = psDefs pstate
}
statement :: Parser Statement
statement = try ifStatement
<|> try withStatement
<|> try switchStatement
<|> try forStatement
<|> try defStatement
<|> try callStatement
<|> try commentStatement
<|> try includeStatement
<|> try interpolateStatement
<|> try newlineStatement
<|> try escapeSequenceStatement
<|> rawTextStatement
commentStatement :: Parser Statement
commentStatement = do
string "{%--"
manyTill
(try (discard commentStatement) <|> discard anyChar)
(try $ string "--%}")
return NullStatement
includeStatement :: Parser Statement
includeStatement = do
(basename, innerContext) <- complexTag "include" inner
dirname <- psBasePath `liftM` getState
extension <- psIncludeExtension `liftM` getState
let fn0 = joinPath [ dirname, basename ]
let fn = maybe fn0 (fillExtension fn0) extension
src <- liftIO $ withFile fn ReadMode hGetContents
subAst <- liftIO $ readPaco fn src
let stmt = astRootStatement subAst
return $ maybe stmt (\(ident, expr) -> LetStatement ident expr stmt) innerContext
where
path :: Parser String
path = many1 $ try $ noneOf " \t\r\n%"
inner :: Parser (String, Maybe (String, Expression))
inner = do
basename <- path
ss_
innerContext <- optionMaybe $ try (ss_ >> string "with" >> ss_ >> letPair)
return (basename, innerContext)
interpolateStatement :: Parser Statement
interpolateStatement = do
char '{'
em <- option (Just EscapeHTML) escapeMode
ss_
expr <- expression
ss_
char '}'
let expr' = maybe
expr
(\m -> EscapeExpression m expr)
em
return $ PrintStatement $ expr'
rawTextStatement :: Parser Statement
rawTextStatement = do
chrs <- many1 $ noneOf "{\\\n"
return $ PrintStatement $ StringLiteral chrs
newlineStatement :: Parser Statement
newlineStatement = do
char '\n'
ss_
return $ PrintStatement $ StringLiteral "\n"
escapeSequenceStatement :: Parser Statement
escapeSequenceStatement = do
char '\\'
c <- anyChar
case c of
'\n' -> return NullStatement
otherwise -> return $ PrintStatement $ StringLiteral [ '\\', c ]
ifStatement :: Parser Statement
ifStatement = do
cond <- complexTag "if" expression
trueStmts <- many statement
let trueBranch = StatementSequence trueStmts
falseBranch <- option NullStatement $ try elseBranch
simpleTag "endif"
return $ IfStatement cond trueBranch falseBranch
where elseBranch =
do
simpleTag "else"
stmts <- many statement
return . StatementSequence $ stmts
withStatement :: Parser Statement
withStatement = withOrForStatement LetStatement "with"
forStatement :: Parser Statement
forStatement = withOrForStatement ForStatement "for"
withOrForStatement :: (String -> Expression -> Statement -> Statement) -> String -> Parser Statement
withOrForStatement ctor keyword = do
(ident, expr) <- complexTag keyword letPair
stmts <- many $ try statement
simpleTag $ "end" ++ keyword
return $ ctor ident expr $ StatementSequence stmts
letPair :: Parser (String, Expression)
letPair = do
expr <- expression
ss_
ident <- option "." $ try $ char ':' >> ss_ >> identifier
ss_
return (ident, expr)
switchStatement :: Parser Statement
switchStatement = do
masterExpr <- complexTag "switch" expression
ss_
branches <- many switchBranch
ss_
simpleTag "endswitch"
return $ SwitchStatement masterExpr branches
where switchBranch = do
ss_
switchExpr <- complexTag "case" expression
stmts <- many statement
simpleTag "endcase"
ss_
return (switchExpr, StatementSequence stmts)
defStatement :: Parser Statement
defStatement = do
name <- complexTag "def" identifier
body <- many statement
simpleTag "enddef"
addDef name $ StatementSequence body
return NullStatement
callStatement :: Parser Statement
callStatement = do
name <- complexTag "call" identifier
optional $ char '\n'
return $ CallStatement name
simpleTag tag = complexTag tag (return ())
complexTag tag inner =
let go = do
string "{%"
ss_
string tag
ss_
i <- inner
ss_
string "%}"
return i
standalone = do
assertStartOfLine
ss_
v <- go
char '\n'
return v
in try standalone <|> try go
expression = booleanExpression
booleanExpression =
binaryExpression
[("&&", OpBooleanAnd),
("||", OpBooleanOr),
("^^", OpBooleanXor)]
setOperationExpression
setOperationExpression =
binaryExpression
[("in", OpInList),
("contains", Flipped OpInList)]
comparativeExpression
comparativeExpression =
binaryExpression
[("==", OpEquals),
("!==", OpNotEquals),
("=", OpLooseEquals),
("!=", OpLooseNotEquals),
(">=", OpNotLess),
(">", OpGreater),
("<=", OpNotGreater),
("<", OpLess)]
additiveExpression
additiveExpression =
binaryExpression
[("+", OpPlus), ("-", OpMinus)]
multiplicativeExpression
multiplicativeExpression =
binaryExpression
[("*", OpMul), ("/", OpDiv), ("%", OpMod)]
(try traditionalFunctionCallExpression <|> postfixExpression)
binaryExpression :: [(String, BinaryOperator)] -> (Parser Expression) -> Parser Expression
binaryExpression opMap innerParser = do
let rem :: Parser (BinaryOperator, Expression)
rem = do
ss_
opStr <- foldl1 (<|>) $ map (try . string . fst) opMap
ss_
let Just op = lookup opStr opMap
e <- innerParser
return (op, e)
left <- innerParser
right <- many $ try rem
return $ foldl combine left right
where
combine :: Expression -> (BinaryOperator, Expression) -> Expression
combine lhs (op, rhs) = BinaryExpression op lhs rhs
traditionalFunctionCallExpression = do
char '$'
args <- manySepBy (try expression) ss_
return $ FunctionCallExpression (head args) (tail args)
postfixExpression = do
left <- (try prefixExpression <|> simpleExpression)
postfixes <- many postfix
return $ foldl combine left postfixes
where
combine :: Expression -> (Expression -> Expression) -> Expression
combine l f = f l
prefixExpression = do
ss_
operator <- unaryOperator
ss_
expr <- (try prefixExpression <|> simpleExpression)
return $ UnaryExpression operator expr
unaryOperator = do
let opMap = [("not", OpNot)]
opStr <- foldl1 (<|>) $ map (try . string . fst) opMap
let Just op = lookup opStr opMap
return op
postfix = try memberAccessPostfix
<|> try indexPostfix
<|> try functionCallPostfix
memberAccessPostfix :: Parser (Expression -> Expression)
memberAccessPostfix = do
char '.'
expr <- StringLiteral `liftM` identifier
return $ \l -> BinaryExpression OpMember l expr
indexPostfix :: Parser (Expression -> Expression)
indexPostfix = do
ss_
char '['
e <- expression
char ']'
ss_
return $ \l -> BinaryExpression OpMember l e
functionCallPostfix :: Parser (Expression -> Expression)
functionCallPostfix = do
char '('
args <- manySepBy (try expression) (try $ ss_ >> char ',' >> ss_)
ss_
char ')'
return $ \l -> FunctionCallExpression l args
simpleExpression :: Parser Expression
simpleExpression = floatLiteral
<|> intLiteral
<|> stringLiteral
<|> listExpression
<|> alistExpression
<|> varRefExpr
<|> bracedExpression
bracedExpression :: Parser Expression
bracedExpression = do
char '('
ss_
inner <- expression
ss_
char ')'
return inner
listExpression :: Parser Expression
listExpression = do
char '['
ss_
items <- manySepBy expression (ss_ >> char ',' >> ss_)
ss_
optional $ char ',' >> ss_
char ']'
return $ ListExpression items
alistExpression :: Parser Expression
alistExpression = do
char '{'
ss_
items <- option [] $ try $ manySepBy elem $ char ','
ss_
optional $ char ',' >> ss_
char '}'
return $ AListExpression items
where
elem :: Parser (Expression, Expression)
elem = do
ss_
key <- expression
ss_ >> char ':' >> ss_
value <- expression
ss_
return (key, value)
intLiteral :: Parser Expression
intLiteral = do
sign <- option '+' $ oneOf "+-"
str <- many1 digit
let str' = if sign == '-' then sign:str else str
return . IntLiteral . read $ str'
floatLiteral :: Parser Expression
floatLiteral = do
str <- (try dpd <|> try pd)
return . FloatLiteral . read $ str
where
dpd = do
sign <- option '+' $ oneOf "+-"
intpart <- many1 digit
char '.'
fracpart <- many digit
let str = intpart ++ "." ++ fracpart
return $ if sign == '-' then sign:str else str
pd = do
sign <- option '+' $ oneOf "+-"
char '.'
fracpart <- many1 digit
let str = "0." ++ fracpart
return $ if sign == '-' then sign:str else str
stringLiteral :: Parser Expression
stringLiteral = do
str <- anyQuotedString
return . StringLiteral $ str
varRefExpr :: Parser Expression
varRefExpr = do
id <- (string "." <|> identifier)
return $ VariableReference id
addDef :: String -> Statement -> Parser ()
addDef name value =
modifyState (\s -> s { psDefs = ((name, value):psDefs s) })
resolveDef :: String -> Parser Statement
resolveDef name = do
defs <- psDefs `liftM` getState
let val = lookup name defs
maybe
(unexpected $ name ++ " is not defined.")
return
val
ss :: a -> Parser a
ss a = skipMany space >> return a
ss_ :: Parser ()
ss_ = ss ()
braces :: Parser a -> Parser a
braces inner = do
char '{'
ss_
v <- inner
ss_
char '}'
return v
escapeMode :: Parser (Maybe EscapeMode)
escapeMode = (char '!' >> return Nothing)
<|> (char '@' >> return (Just EscapeURL))
identifier :: Parser String
identifier = do
x <- letter <|> char '_'
xs <- many $ letter <|> digit <|> char '_'
return $ x:xs
anyQuotedString = singleQuotedString <|> doubleQuotedString
singleQuotedString = quotedString '\''
doubleQuotedString = quotedString '"'
quotedString qc = do
char qc
str <- many $ quotedStringChar qc
char qc
return str
quotedStringChar qc =
try escapedChar
<|> noneOf [qc]
escapedChar = do
char '\\'
c2 <- anyChar
return $ case c2 of
'n' -> '\n'
'r' -> '\r'
'b' -> '\b'
't' -> '\t'
otherwise -> c2
discard :: Parser a -> Parser ()
discard p = p >> return ()
manySepBy :: Parser a -> Parser b -> Parser [a]
manySepBy elem sep = do
h <- try elem
t <- many (try $ sep >> elem)
return $ h:t
assertStartOfInput :: Parser ()
assertStartOfInput = do
pos <- getPosition
if sourceLine pos == 1 && sourceColumn pos == 1
then return ()
else unexpected "start of input"
assertStartOfLine :: Parser ()
assertStartOfLine = do
pos <- getPosition
if sourceColumn pos == 1
then return ()
else unexpected "start of line"
fillExtension :: FilePath -> String -> FilePath
fillExtension fp ext =
let ext0 = takeExtension fp
in if null ext0
then replaceExtension fp ext
else fp