{- -----------------------------------------------------------------------------
Copyright 2020 Kevin P. Barry

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
----------------------------------------------------------------------------- -}

-- Author: Kevin P. Barry [ta0kira@gmail.com]

{-# LANGUAGE Safe #-}

module Parser.Pragma (
  parseMacroName,
  parsePragmas,
  pragmaComment,
  pragmaExprLookup,
  pragmaNoTrace,
  pragmaModuleOnly,
  pragmaSourceContext,
  pragmaTestsOnly,
  pragmaTraceCreation,
) where

import Control.Monad (when)
import Text.Parsec
import Text.Parsec.String

import Parser.Common
import Types.Pragma


parsePragmas :: [Parser a] -> Parser [a]
parsePragmas :: [Parser a] -> Parser [a]
parsePragmas = Parser a -> Parser [a]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (Parser a -> Parser [a])
-> ([Parser a] -> Parser a) -> [Parser a] -> Parser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser a -> Parser a -> Parser a)
-> Parser a -> [Parser a] -> Parser a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Parser a -> Parser a -> Parser a
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
(<|>)) Parser a
forall a. Parser a
unknownPragma

pragmaModuleOnly :: Parser (Pragma SourcePos)
pragmaModuleOnly :: Parser (Pragma SourcePos)
pragmaModuleOnly = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"ModuleOnly" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. a -> Either a b
Left SourcePos -> Pragma SourcePos
forall c. c -> Pragma c
parseAt where
  parseAt :: c -> Pragma c
parseAt c
c = [c] -> CodeVisibility -> Pragma c
forall c. [c] -> CodeVisibility -> Pragma c
PragmaVisibility [c
c] CodeVisibility
ModuleOnly

parseMacroName :: Parser String
parseMacroName :: Parser String
parseMacroName = String -> Parser String -> Parser String
forall a. String -> Parser a -> Parser a
labeled String
"macro name" (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ do
  Char
h <- ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
upper ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_'
  String
t <- ParsecT String () Identity Char -> Parser String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
upper ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'_')
  Parser ()
optionalSpace
  String -> Parser String
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
hChar -> String -> String
forall a. a -> [a] -> [a]
:String
t)

pragmaExprLookup :: Parser (Pragma SourcePos)
pragmaExprLookup :: Parser (Pragma SourcePos)
pragmaExprLookup = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"ExprLookup" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. b -> Either a b
Right SourcePos -> Parser (Pragma SourcePos)
forall c. c -> ParsecT String () Identity (Pragma c)
parseAt where
  parseAt :: c -> ParsecT String () Identity (Pragma c)
parseAt c
c = do
    String
name <- Parser String
parseMacroName
    Pragma c -> ParsecT String () Identity (Pragma c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma c -> ParsecT String () Identity (Pragma c))
-> Pragma c -> ParsecT String () Identity (Pragma c)
forall a b. (a -> b) -> a -> b
$ [c] -> String -> Pragma c
forall c. [c] -> String -> Pragma c
PragmaExprLookup [c
c] String
name

pragmaSourceContext :: Parser (Pragma SourcePos)
pragmaSourceContext :: Parser (Pragma SourcePos)
pragmaSourceContext = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"SourceContext" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. a -> Either a b
Left SourcePos -> Pragma SourcePos
forall c. c -> Pragma c
parseAt where
  parseAt :: c -> Pragma c
parseAt c
c = c -> Pragma c
forall c. c -> Pragma c
PragmaSourceContext c
c

pragmaNoTrace :: Parser (Pragma SourcePos)
pragmaNoTrace :: Parser (Pragma SourcePos)
pragmaNoTrace = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"NoTrace" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. a -> Either a b
Left SourcePos -> Pragma SourcePos
forall c. c -> Pragma c
parseAt where
  parseAt :: c -> Pragma c
parseAt c
c = [c] -> TraceType -> Pragma c
forall c. [c] -> TraceType -> Pragma c
PragmaTracing [c
c] TraceType
NoTrace

pragmaTraceCreation :: Parser (Pragma SourcePos)
pragmaTraceCreation :: Parser (Pragma SourcePos)
pragmaTraceCreation = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"TraceCreation" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. a -> Either a b
Left SourcePos -> Pragma SourcePos
forall c. c -> Pragma c
parseAt where
  parseAt :: c -> Pragma c
parseAt c
c = [c] -> TraceType -> Pragma c
forall c. [c] -> TraceType -> Pragma c
PragmaTracing [c
c] TraceType
TraceCreation

pragmaTestsOnly :: Parser (Pragma SourcePos)
pragmaTestsOnly :: Parser (Pragma SourcePos)
pragmaTestsOnly = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"TestsOnly" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. a -> Either a b
Left SourcePos -> Pragma SourcePos
forall c. c -> Pragma c
parseAt where
  parseAt :: c -> Pragma c
parseAt c
c = [c] -> CodeVisibility -> Pragma c
forall c. [c] -> CodeVisibility -> Pragma c
PragmaVisibility [c
c] CodeVisibility
TestsOnly

pragmaComment :: Parser (Pragma SourcePos)
pragmaComment :: Parser (Pragma SourcePos)
pragmaComment = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a.
String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
"Comment" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> Parser (Pragma SourcePos))
 -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
-> Parser (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Parser (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> Parser (Pragma SourcePos))
forall a b. b -> Either a b
Right SourcePos -> Parser (Pragma SourcePos)
forall c. c -> ParsecT String () Identity (Pragma c)
parseAt where
  parseAt :: c -> ParsecT String () Identity (Pragma c)
parseAt c
c = do
    String -> Parser ()
string_ String
"\""
    String
ss <- ParsecT String () Identity Char -> Parser () -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
stringChar (String -> Parser ()
string_ String
"\"")
    Parser ()
optionalSpace
    Pragma c -> ParsecT String () Identity (Pragma c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma c -> ParsecT String () Identity (Pragma c))
-> Pragma c -> ParsecT String () Identity (Pragma c)
forall a b. (a -> b) -> a -> b
$ [c] -> String -> Pragma c
forall c. [c] -> String -> Pragma c
PragmaComment [c
c] String
ss

unknownPragma :: Parser a
unknownPragma :: Parser a
unknownPragma = do
  Parser () -> Parser ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser ()
pragmaStart
  String
p <- ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
  String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"Pragma " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not supported in this context"

autoPragma :: String -> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma :: String
-> Either (SourcePos -> a) (SourcePos -> Parser a) -> Parser a
autoPragma String
p Either (SourcePos -> a) (SourcePos -> Parser a)
f = do
  SourcePos
c <- ParsecT String () Identity SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  Parser () -> Parser ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ Parser ()
pragmaStart Parser () -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Parser ()
string_ String
p Parser () -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () Identity Char -> Parser ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
  Bool
hasArgs <- (Parser ()
pragmaArgsStart Parser () -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
optionalSpace Parser ()
-> ParsecT String () Identity Bool
-> ParsecT String () Identity Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ParsecT String () Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) ParsecT String () Identity Bool
-> ParsecT String () Identity Bool
-> ParsecT String () Identity Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Bool -> ParsecT String () Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  a
x <- Bool
-> Either (SourcePos -> a) (SourcePos -> Parser a)
-> SourcePos
-> Parser a
forall (m :: * -> *) t a.
MonadFail m =>
Bool -> Either (t -> a) (t -> m a) -> t -> m a
delegate Bool
hasArgs Either (SourcePos -> a) (SourcePos -> Parser a)
f SourcePos
c
  if Bool
hasArgs
     then do
       String
extra <- ParsecT String () Identity Char -> Parser () -> Parser String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (String -> Parser ()
string_ String
"]$")
       Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
extra) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Content unused by pragma " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extra
       Parser ()
optionalSpace
     else Parser () -> Parser ()
forall a. Parser a -> Parser a
sepAfter Parser ()
pragmaEnd
  a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x where
    delegate :: Bool -> Either (t -> a) (t -> m a) -> t -> m a
delegate Bool
False (Left t -> a
f2)  t
c = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ t -> a
f2 t
c
    delegate Bool
True  (Right t -> m a
f2) t
c = t -> m a
f2 t
c
    delegate Bool
_     (Left t -> a
_)   t
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Pragma " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not allow arguments using []"
    delegate Bool
_     (Right t -> m a
_)  t
_ = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Pragma " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" requires arguments using []"