language-ninja-0.2.0: library/Language/Ninja/Lexer.hs
-- -*- coding: utf-8; mode: haskell; -*-
-- File: library/Language/Ninja/Lexer.hs
--
-- License:
-- Copyright Neil Mitchell 2011-2017.
-- Copyright Awake Networks 2017.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
-- * Redistributions of source code must retain the above copyright
-- notice, this list of conditions and the following disclaimer.
--
-- * Redistributions in binary form must reproduce the above
-- copyright notice, this list of conditions and the following
-- disclaimer in the documentation and/or other materials provided
-- with the distribution.
--
-- * Neither the name of Neil Mitchell nor the names of other
-- contributors may be used to endorse or promote products derived
-- from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module : Language.Ninja.Lexer
-- Copyright : Copyright 2011-2017 Neil Mitchell
-- License : BSD3
-- Maintainer : opensource@awakesecurity.com
-- Stability : experimental
--
-- Lexing is a slow point, the code below is optimised.
--
-- @since 0.1.0
module Language.Ninja.Lexer
( -- * @lex*IO@
lexFileIO
, lexTextIO
, lexBSIO
-- * @lex*@
, lexFile
, lexText
, lexBS
-- * @lex*WithPath@
, lexTextWithPath
, lexBSWithPath
-- * Other ways of running the lexer
, lexemesP
-- * Type aliases
, Lexer.Parser
, Lexer.Ann
-- * @Lexeme@ and friends
, Lexer.Lexeme (..)
, Lexer.LName (..)
, Lexer.LFile (..)
, Lexer.LBind (..)
, Lexer.LBuild (..), Lexer.makeLBuild
-- * Classes
, Lexer.PositionParsing (..)
) where
import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second)
import Control.Exception (throwIO)
import Control.Monad (unless, void, (>=>))
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Trans.Except (runExceptT)
import qualified Control.Lens as Lens
import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Char (isSpace)
import Data.Foldable (asum)
#if __GLASGOW_HASKELL__ >= 800
import Data.Functor ((<$))
#endif
import Data.Maybe (catMaybes, fromMaybe)
import Flow ((.>), (|>))
import qualified Text.Megaparsec as M
import qualified Text.Megaparsec.Lexer as M.Lexer
import qualified Language.Ninja.AST as AST
import qualified Language.Ninja.Errors as Errors
import qualified Language.Ninja.Lexer.Types as Lexer
import qualified Language.Ninja.Misc as Misc
import qualified Language.Ninja.Mock as Mock
--------------------------------------------------------------------------------
-- | Lex the file at the given path.
-- This function may throw an exception if parsing fails.
--
-- @since 0.1.0
lexFileIO :: Misc.Path -> IO [Lexer.Lexeme Lexer.Ann]
lexFileIO = (lexFile .> runExceptT) >=> either throwIO pure
-- | Lex the given 'Text'.
-- This function may throw an exception if parsing fails.
--
-- @since 0.1.0
lexTextIO :: Text -> IO [Lexer.Lexeme Lexer.Ann]
lexTextIO = (lexText .> runExceptT) >=> either throwIO pure
-- | Lex the given 'ByteString'.
-- This function may throw an exception if parsing fails.
--
-- @since 0.1.0
lexBSIO :: ByteString -> IO [Lexer.Lexeme Lexer.Ann]
lexBSIO = (lexBS .> runExceptT) >=> either throwIO pure
--------------------------------------------------------------------------------
-- | Lex the given file.
--
-- @since 0.1.0
lexFile :: (MonadError Errors.ParseError m, Mock.MonadReadFile m)
=> Misc.Path -> m [Lexer.Lexeme Lexer.Ann]
lexFile file = Mock.readFile file >>= lexTextWithPath (Just file)
-- | Lex the given 'Text'.
--
-- @since 0.1.0
lexText :: (MonadError Errors.ParseError m)
=> Text -> m [Lexer.Lexeme Lexer.Ann]
lexText = lexTextWithPath Nothing
-- | Lex the given 'BSC8.ByteString'.
--
-- @since 0.1.0
lexBS :: (MonadError Errors.ParseError m)
=> ByteString -> m [Lexer.Lexeme Lexer.Ann]
lexBS = lexBSWithPath Nothing
--------------------------------------------------------------------------------
-- | Lex the given 'Text' that comes from the given 'Misc.Path', if provided.
--
-- @since 0.1.0
lexTextWithPath :: (MonadError Errors.ParseError m)
=> Maybe Misc.Path -> Text -> m [Lexer.Lexeme Lexer.Ann]
lexTextWithPath mp x = M.runParserT lexemesP file x
>>= either Errors.throwLexParsecError pure
where
file = fromMaybe "" (Lens.view Misc.pathString <$> mp)
-- | Lex the given 'ByteString' that comes from the given 'Misc.Path', if it is
-- provided. The 'Misc.Path' is only used for error messages.
--
-- @since 0.1.0
lexBSWithPath :: (MonadError Errors.ParseError m)
=> Maybe Misc.Path -> ByteString -> m [Lexer.Lexeme Lexer.Ann]
lexBSWithPath mpath = Text.decodeUtf8 .> lexTextWithPath mpath
--------------------------------------------------------------------------------
-- | The @megaparsec@ parser for a Ninja file.
--
-- @since 0.1.0
lexemesP :: Lexer.Parser m [Lexer.Lexeme Lexer.Ann]
lexemesP = do
maybes <- [ Nothing <$ lineCommentP
, Nothing <$ M.separatorChar
, Nothing <$ M.eol
, Just <$> (lexemeP <* lineEndP)
] |> asum |> M.many
M.eof
pure (catMaybes maybes)
--------------------------------------------------------------------------------
lexemeP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
lexemeP = [ includeP, subninjaP, buildP, ruleP, poolP, defaultP, bindP, defineP
] |> map M.try |> asum
defineP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
defineP = Lexer.spanned equationP
|> fmap (uncurry Lexer.LexDefine)
|> debugP "defineP"
bindP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
bindP = Lexer.spanned (indented f)
|> fmap (uncurry Lexer.LexBind)
|> debugP "bindP"
where
f :: Misc.Column -> Lexer.Parser m (Lexer.LBind Lexer.Ann)
f x | x < 2 = fail "bindP: not indented"
f _ = equationP
includeP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
includeP = debugP "includeP" $ do
(ann, file) <- Lexer.spanned $ do
beginningOfLine
symbolP "include"
M.Lexer.lexeme spaceP fileP
pure (Lexer.LexInclude ann file)
subninjaP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
subninjaP = debugP "subninjaP" $ do
(ann, file) <- Lexer.spanned $ do
beginningOfLine
symbolP "subninja"
M.Lexer.lexeme spaceP fileP
pure (Lexer.LexSubninja ann file)
buildP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
buildP = debugP "buildP" $ do
let isExprEmpty :: AST.Expr Lexer.Ann -> Bool
isExprEmpty (AST.Lit _ "") = True
isExprEmpty (AST.Exprs _ []) = True
isExprEmpty _ = False
let cleanExprs :: [AST.Expr Lexer.Ann] -> [AST.Expr Lexer.Ann]
cleanExprs = map AST.normalizeExpr .> filter (isExprEmpty .> not)
(ann, (outs, rule, deps)) <- Lexer.spanned $ do
beginningOfLine
symbolP "build"
outs <- cleanExprs <$> M.some outputP
symbolP ":"
rule <- nameP
deps <- cleanExprs <$> M.many (M.Lexer.lexeme spaceP exprP)
pure (outs, rule, deps)
pure (Lexer.LexBuild ann (Lexer.MkLBuild ann outs rule deps))
ruleP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
ruleP = debugP "ruleP" $ do
(ann, ruleName) <- Lexer.spanned $ do
beginningOfLine
symbolP "rule"
nameP
pure (Lexer.LexRule ann ruleName)
poolP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
poolP = debugP "poolP" $ do
(ann, poolName) <- Lexer.spanned $ do
beginningOfLine
symbolP "pool"
nameP
pure (Lexer.LexPool ann poolName)
defaultP :: Lexer.Parser m (Lexer.Lexeme Lexer.Ann)
defaultP = debugP "defaultP" $ do
(ann, defaults) <- Lexer.spanned $ do
beginningOfLine
symbolP "default"
M.many (M.Lexer.lexeme spaceP exprP)
pure (Lexer.LexDefault ann defaults)
lineEndP :: Lexer.Parser m ()
lineEndP = do
M.many M.separatorChar
lineCommentP <|> pure ()
void M.eol
equationP :: Lexer.Parser m (Lexer.LBind Lexer.Ann)
equationP = debugP "equationP" $ do
(ann, (name, value)) <- Lexer.spanned $ do
name <- nameP
symbolP "="
value <- exprsP
pure (name, value)
pure (Lexer.MkLBind ann name value)
nameP :: Lexer.Parser m (Lexer.LName Lexer.Ann)
nameP = Lexer.spanned varDotP
|> fmap (second (Text.pack .> Text.encodeUtf8))
|> fmap (uncurry Lexer.MkLName)
|> M.Lexer.lexeme spaceP
|> debugP "nameP"
fileP :: Lexer.Parser m (Lexer.LFile Lexer.Ann)
fileP = Lexer.MkLFile <$> exprP
|> M.Lexer.lexeme spaceP
|> debugP "fileP"
outputP :: Lexer.Parser m (AST.Expr Lexer.Ann)
outputP = Lexer.spanned (M.some (dollarP <|> litP))
|> fmap (uncurry AST.Exprs .> AST.normalizeExpr)
|> M.Lexer.lexeme spaceP
where
litP :: Lexer.Parser m (AST.Expr Lexer.Ann)
litP = Lexer.spanned (M.some (M.satisfy isOutputChar))
|> fmap (second Text.pack .> uncurry AST.Lit)
isOutputChar :: Char -> Bool
isOutputChar '$' = False
isOutputChar ':' = False
isOutputChar '\n' = False
isOutputChar '\r' = False
isOutputChar c | isSpace c = False
isOutputChar _ = True
exprsP :: Lexer.Parser m (AST.Expr Lexer.Ann)
exprsP = asum [exprP, separatorP]
|> M.many
|> Lexer.spanned
|> fmap (uncurry AST.Exprs .> AST.normalizeExpr)
where
separatorP :: Lexer.Parser m (AST.Expr Lexer.Ann)
separatorP = Lexer.spanned (M.some M.separatorChar)
|> fmap (second Text.pack .> uncurry AST.Lit)
exprP :: Lexer.Parser m (AST.Expr Lexer.Ann)
exprP = Lexer.spanned (M.some (dollarP <|> litP))
|> fmap (uncurry AST.Exprs .> AST.normalizeExpr)
where
litP :: Lexer.Parser m (AST.Expr Lexer.Ann)
litP = Lexer.spanned (M.some (M.satisfy isExprChar))
|> fmap (second Text.pack .> uncurry AST.Lit)
isExprChar :: Char -> Bool
isExprChar '$' = False
isExprChar '\n' = False
isExprChar '\r' = False
isExprChar c | isSpace c = False
isExprChar _ = True
dollarP :: Lexer.Parser m (AST.Expr Lexer.Ann)
dollarP = debugP "dollarP"
(M.char '$'
*> ([ makeLit (M.string "$")
, makeLit (M.string " ")
, makeLit (M.string ":")
, makeLit ((M.eol *> M.many M.separatorChar *> pure ""))
, makeVar ((M.char '{' *> varDotP <* M.char '}'))
, makeVar varP
] |> asum))
where
makeLit :: Lexer.Parser m String -> Lexer.Parser m (AST.Expr Lexer.Ann)
makeLit p = Lexer.spanned p |> fmap (second Text.pack .> uncurry AST.Lit)
makeVar :: Lexer.Parser m String -> Lexer.Parser m (AST.Expr Lexer.Ann)
makeVar p = Lexer.spanned p |> fmap (second Text.pack .> uncurry AST.Var)
varDotP :: Lexer.Parser m String
varDotP = M.some (M.alphaNumChar <|> M.oneOf ['/', '-', '_', '.'])
|> debugP "varDotP"
varP :: Lexer.Parser m String
varP = M.some (M.alphaNumChar <|> M.oneOf ['/', '-', '_'])
|> debugP "varP"
symbolP :: String -> Lexer.Parser m String
symbolP = M.Lexer.symbol spaceP
spaceP :: Lexer.Parser m ()
spaceP = M.Lexer.space (void M.separatorChar) lineCommentP blockCommentP
lineCommentP :: Lexer.Parser m ()
lineCommentP = M.Lexer.skipLineComment "#"
blockCommentP :: Lexer.Parser m ()
blockCommentP = fail "always"
indented :: (Misc.Column -> Lexer.Parser m a) -> Lexer.Parser m a
indented f = do
M.many M.separatorChar
Lexer.getPosition >>= Lens.view Misc.positionCol .> f
beginningOfLine :: Lexer.Parser m ()
beginningOfLine = do
col <- Lens.view Misc.positionCol <$> Lexer.getPosition
unless (col == 1) (fail "beginningOfLine failed")
debugP :: (Show a) => String -> Lexer.Parser m a -> Lexer.Parser m a
debugP str p = M.label str p -- M.dbg str p
where
-- this shuts up the compiler wrt the Show constraint
_ = show <$> p
--------------------------------------------------------------------------------