{- -----------------------------------------------------------------------------
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]

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

import Control.Monad (when)

import Base.CompilerError
import Parser.Common
import Parser.TextParser
import Types.Pragma


parsePragmas :: [TextParser a] -> TextParser [a]
parsePragmas :: [TextParser a] -> TextParser [a]
parsePragmas = TextParser a -> TextParser [a]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (TextParser a -> TextParser [a])
-> ([TextParser a] -> TextParser a)
-> [TextParser a]
-> TextParser [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextParser a -> TextParser a -> TextParser a)
-> TextParser a -> [TextParser a] -> TextParser a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TextParser a -> TextParser a -> TextParser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)) TextParser a
forall a. TextParser a
unknownPragma

pragmaModuleOnly :: TextParser (Pragma SourceContext)
pragmaModuleOnly :: TextParser (Pragma SourceContext)
pragmaModuleOnly = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"ModuleOnly" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> Pragma SourceContext)
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. a -> Either a b
Left SourceContext -> Pragma SourceContext
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

instance ParseFromSource MacroName where
  sourceParser :: TextParser MacroName
sourceParser = String -> TextParser MacroName -> TextParser MacroName
forall a. String -> TextParser a -> TextParser a
labeled String
"macro name" (TextParser MacroName -> TextParser MacroName)
-> TextParser MacroName -> TextParser MacroName
forall a b. (a -> b) -> a -> b
$ do
    Char
h <- ParsecT CompilerMessage String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String
-> ParsecT CompilerMessage String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'_'
    String
t <- ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT CompilerMessage String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
upperChar ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CompilerMessage String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String
-> ParsecT CompilerMessage String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'_')
    TextParser ()
optionalSpace
    MacroName -> TextParser MacroName
forall (m :: * -> *) a. Monad m => a -> m a
return (MacroName -> TextParser MacroName)
-> MacroName -> TextParser MacroName
forall a b. (a -> b) -> a -> b
$ String -> MacroName
MacroName (Char
hChar -> String -> String
forall a. a -> [a] -> [a]
:String
t)

pragmaExprLookup :: TextParser (Pragma SourceContext)
pragmaExprLookup :: TextParser (Pragma SourceContext)
pragmaExprLookup = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"ExprLookup" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. b -> Either a b
Right SourceContext -> TextParser (Pragma SourceContext)
forall c. c -> ParsecT CompilerMessage String Identity (Pragma c)
parseAt where
  parseAt :: c -> ParsecT CompilerMessage String Identity (Pragma c)
parseAt c
c = do
    MacroName
name <- TextParser MacroName
forall a. ParseFromSource a => TextParser a
sourceParser
    Pragma c -> ParsecT CompilerMessage String Identity (Pragma c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma c -> ParsecT CompilerMessage String Identity (Pragma c))
-> Pragma c -> ParsecT CompilerMessage String Identity (Pragma c)
forall a b. (a -> b) -> a -> b
$ [c] -> MacroName -> Pragma c
forall c. [c] -> MacroName -> Pragma c
PragmaExprLookup [c
c] MacroName
name

pragmaSourceContext :: TextParser (Pragma SourceContext)
pragmaSourceContext :: TextParser (Pragma SourceContext)
pragmaSourceContext = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"SourceContext" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> Pragma SourceContext)
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. a -> Either a b
Left SourceContext -> Pragma SourceContext
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 :: TextParser (Pragma SourceContext)
pragmaNoTrace :: TextParser (Pragma SourceContext)
pragmaNoTrace = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"NoTrace" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> Pragma SourceContext)
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. a -> Either a b
Left SourceContext -> Pragma SourceContext
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 :: TextParser (Pragma SourceContext)
pragmaTraceCreation :: TextParser (Pragma SourceContext)
pragmaTraceCreation = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"TraceCreation" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> Pragma SourceContext)
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. a -> Either a b
Left SourceContext -> Pragma SourceContext
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 :: TextParser (Pragma SourceContext)
pragmaTestsOnly :: TextParser (Pragma SourceContext)
pragmaTestsOnly = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"TestsOnly" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> Pragma SourceContext)
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. a -> Either a b
Left SourceContext -> Pragma SourceContext
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 :: TextParser (Pragma SourceContext)
pragmaComment :: TextParser (Pragma SourceContext)
pragmaComment = String
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"Comment" (Either
   (SourceContext -> Pragma SourceContext)
   (SourceContext -> TextParser (Pragma SourceContext))
 -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
-> TextParser (Pragma SourceContext)
forall a b. (a -> b) -> a -> b
$ (SourceContext -> TextParser (Pragma SourceContext))
-> Either
     (SourceContext -> Pragma SourceContext)
     (SourceContext -> TextParser (Pragma SourceContext))
forall a b. b -> Either a b
Right SourceContext -> TextParser (Pragma SourceContext)
forall c. c -> ParsecT CompilerMessage String Identity (Pragma c)
parseAt where
  parseAt :: c -> ParsecT CompilerMessage String Identity (Pragma c)
parseAt c
c = do
    String -> TextParser ()
string_ String
"\""
    String
ss <- ParsecT CompilerMessage String Identity Char
-> TextParser () -> ParsecT CompilerMessage String Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT CompilerMessage String Identity Char
stringChar (String -> TextParser ()
string_ String
"\"")
    TextParser ()
optionalSpace
    Pragma c -> ParsecT CompilerMessage String Identity (Pragma c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma c -> ParsecT CompilerMessage String Identity (Pragma c))
-> Pragma c -> ParsecT CompilerMessage 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 :: TextParser a
unknownPragma :: TextParser a
unknownPragma = do
  TextParser () -> TextParser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try TextParser ()
pragmaStart
  String
p <- ParsecT CompilerMessage String Identity Char
-> ParsecT CompilerMessage String Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT CompilerMessage String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  String -> TextParser a
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> TextParser a) -> String -> TextParser 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 (SourceContext -> a) (SourceContext -> TextParser a) -> TextParser a
autoPragma :: String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
p Either (SourceContext -> a) (SourceContext -> TextParser a)
f = do
  SourceContext
c <- TextParser SourceContext
getSourceContext
  TextParser () -> TextParser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (TextParser () -> TextParser ()) -> TextParser () -> TextParser ()
forall a b. (a -> b) -> a -> b
$ TextParser ()
pragmaStart TextParser () -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> TextParser ()
string_ String
p TextParser () -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT CompilerMessage String Identity Char -> TextParser ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT CompilerMessage String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  Bool
hasArgs <- (TextParser ()
pragmaArgsStart TextParser () -> TextParser () -> TextParser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
optionalSpace TextParser ()
-> ParsecT CompilerMessage String Identity Bool
-> ParsecT CompilerMessage String Identity Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ParsecT CompilerMessage String Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) ParsecT CompilerMessage String Identity Bool
-> ParsecT CompilerMessage String Identity Bool
-> ParsecT CompilerMessage String Identity Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> ParsecT CompilerMessage String Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  a
x <- Bool
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> SourceContext
-> TextParser a
forall (m :: * -> *) t a.
ErrorContextM m =>
Bool -> Either (t -> a) (t -> m a) -> t -> m a
delegate Bool
hasArgs Either (SourceContext -> a) (SourceContext -> TextParser a)
f SourceContext
c
  if Bool
hasArgs
     then do
       String
extra <- ParsecT CompilerMessage String Identity Char
-> TextParser () -> ParsecT CompilerMessage String Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT CompilerMessage String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
asciiChar (String -> TextParser ()
string_ String
"]$")
       Bool -> TextParser () -> TextParser ()
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) (TextParser () -> TextParser ()) -> TextParser () -> TextParser ()
forall a b. (a -> b) -> a -> b
$ String -> TextParser ()
forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM (String -> TextParser ()) -> String -> TextParser ()
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
       TextParser ()
optionalSpace
     else TextParser () -> TextParser ()
forall a. TextParser a -> TextParser a
sepAfter TextParser ()
pragmaEnd
  a -> TextParser 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. ErrorContextM m => String -> m a
compilerErrorM (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. ErrorContextM m => String -> m a
compilerErrorM (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 []"