{- -----------------------------------------------------------------------------
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 (
  parsePragmas,
  pragmaComment,
  pragmaExprLookup,
  pragmaNoTrace,
  pragmaModuleOnly,
  pragmaSourceContext,
  pragmaTestsOnly,
  pragmaTraceCreation,
) where

import Control.Monad (when)
import Text.Parsec

import Base.CompileError
import Parser.Common
import Types.Pragma


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

pragmaModuleOnly :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaModuleOnly :: ParserE m (Pragma SourcePos)
pragmaModuleOnly = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"ModuleOnly" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (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

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

pragmaExprLookup :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaExprLookup :: ParserE m (Pragma SourcePos)
pragmaExprLookup = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"ExprLookup" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
forall a b. b -> Either a b
Right SourcePos -> ParserE m (Pragma SourcePos)
forall (m :: * -> *) c.
CompileErrorM m =>
c -> ParsecT String () m (Pragma c)
parseAt where
  parseAt :: c -> ParsecT String () m (Pragma c)
parseAt c
c = do
    MacroName
name <- ParserE m MacroName
forall a (m :: * -> *).
(ParseFromSource a, CompileErrorM m) =>
ParserE m a
sourceParser
    Pragma c -> ParsecT String () m (Pragma c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma c -> ParsecT String () m (Pragma c))
-> Pragma c -> ParsecT String () m (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 :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaSourceContext :: ParserE m (Pragma SourcePos)
pragmaSourceContext = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"SourceContext" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (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 :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaNoTrace :: ParserE m (Pragma SourcePos)
pragmaNoTrace = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"NoTrace" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (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 :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaTraceCreation :: ParserE m (Pragma SourcePos)
pragmaTraceCreation = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"TraceCreation" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (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 :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaTestsOnly :: ParserE m (Pragma SourcePos)
pragmaTestsOnly = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"TestsOnly" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> Pragma SourcePos)
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (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 :: CompileErrorM m => ParserE m (Pragma SourcePos)
pragmaComment :: ParserE m (Pragma SourcePos)
pragmaComment = String
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall (m :: * -> *) a.
CompileErrorM m =>
String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
"Comment" (Either
   (SourcePos -> Pragma SourcePos)
   (SourcePos -> ParserE m (Pragma SourcePos))
 -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
-> ParserE m (Pragma SourcePos)
forall a b. (a -> b) -> a -> b
$ (SourcePos -> ParserE m (Pragma SourcePos))
-> Either
     (SourcePos -> Pragma SourcePos)
     (SourcePos -> ParserE m (Pragma SourcePos))
forall a b. b -> Either a b
Right SourcePos -> ParserE m (Pragma SourcePos)
forall (m :: * -> *) c.
Monad m =>
c -> ParsecT String () m (Pragma c)
parseAt where
  parseAt :: c -> ParsecT String () m (Pragma c)
parseAt c
c = do
    String -> ParserE m ()
forall (m :: * -> *). Monad m => String -> ParserE m ()
string_ String
"\""
    String
ss <- ParsecT String () m Char
-> ParserE m () -> ParsecT String () m 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 () m Char
forall (m :: * -> *). Monad m => ParserE m Char
stringChar (String -> ParserE m ()
forall (m :: * -> *). Monad m => String -> ParserE m ()
string_ String
"\"")
    ParserE m ()
forall (m :: * -> *). Monad m => ParserE m ()
optionalSpace
    Pragma c -> ParsecT String () m (Pragma c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pragma c -> ParsecT String () m (Pragma c))
-> Pragma c -> ParsecT String () m (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 :: CompileErrorM m => ParserE m a
unknownPragma :: ParserE m a
unknownPragma = do
  SourcePos
c <- ParsecT String () m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  ParsecT String () m () -> ParsecT String () m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT String () m ()
forall (m :: * -> *). Monad m => ParserE m ()
pragmaStart
  String
p <- ParsecT String () m Char -> ParsecT String () m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
  SourcePos -> String -> ParserE m a
forall (m :: * -> *) a.
CompileErrorM m =>
SourcePos -> String -> ParserE m a
parseErrorM SourcePos
c (String -> ParserE m a) -> String -> ParserE 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
" is not supported in this context"

autoPragma :: CompileErrorM m => String -> Either (SourcePos -> a) (SourcePos -> ParserE m a) -> ParserE m a
autoPragma :: String
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> ParserE m a
autoPragma String
p Either (SourcePos -> a) (SourcePos -> ParserE m a)
f = do
  SourcePos
c <- ParsecT String () m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
  ParsecT String () m () -> ParsecT String () m ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT String () m () -> ParsecT String () m ())
-> ParsecT String () m () -> ParsecT String () m ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () m ()
forall (m :: * -> *). Monad m => ParserE m ()
pragmaStart ParsecT String () m ()
-> ParsecT String () m () -> ParsecT String () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ParsecT String () m ()
forall (m :: * -> *). Monad m => String -> ParserE m ()
string_ String
p ParsecT String () m ()
-> ParsecT String () m () -> ParsecT String () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () m Char -> ParsecT String () m ()
forall s (m :: * -> *) t a u.
(Stream s m t, Show a) =>
ParsecT s u m a -> ParsecT s u m ()
notFollowedBy ParsecT String () m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum
  Bool
hasArgs <- (ParsecT String () m ()
forall (m :: * -> *). Monad m => ParserE m ()
pragmaArgsStart ParsecT String () m ()
-> ParsecT String () m () -> ParsecT String () m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String () m ()
forall (m :: * -> *). Monad m => ParserE m ()
optionalSpace ParsecT String () m ()
-> ParsecT String () m Bool -> ParsecT String () m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> ParsecT String () m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) ParsecT String () m Bool
-> ParsecT String () m Bool -> ParsecT String () m Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Bool -> ParsecT String () m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  a
x <- Bool
-> Either (SourcePos -> a) (SourcePos -> ParserE m a)
-> SourcePos
-> ParserE m a
forall (m :: * -> *) a.
CompileErrorM m =>
Bool
-> Either (SourcePos -> a) (SourcePos -> ParsecT String () m a)
-> SourcePos
-> ParsecT String () m a
delegate Bool
hasArgs Either (SourcePos -> a) (SourcePos -> ParserE m a)
f SourcePos
c
  if Bool
hasArgs
     then do
       String
extra <- ParsecT String () m Char
-> ParsecT String () m () -> ParsecT String () m 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 () m Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (String -> ParsecT String () m ()
forall (m :: * -> *). Monad m => String -> ParserE m ()
string_ String
"]$")
       Bool -> ParsecT String () m () -> ParsecT String () m ()
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) (ParsecT String () m () -> ParsecT String () m ())
-> ParsecT String () m () -> ParsecT String () m ()
forall a b. (a -> b) -> a -> b
$ SourcePos -> String -> ParsecT String () m ()
forall (m :: * -> *) a.
CompileErrorM m =>
SourcePos -> String -> ParserE m a
parseErrorM SourcePos
c (String -> ParsecT String () m ())
-> String -> ParsecT String () m ()
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
       ParsecT String () m ()
forall (m :: * -> *). Monad m => ParserE m ()
optionalSpace
     else ParsecT String () m () -> ParsecT String () m ()
forall (m :: * -> *) a. Monad m => ParserE m a -> ParserE m a
sepAfter ParsecT String () m ()
forall (m :: * -> *). Monad m => ParserE m ()
pragmaEnd
  a -> ParserE m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x where
    delegate :: Bool
-> Either (SourcePos -> a) (SourcePos -> ParsecT String () m a)
-> SourcePos
-> ParsecT String () m a
delegate Bool
False (Left SourcePos -> a
f2)  SourcePos
c = a -> ParsecT String () m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ParsecT String () m a) -> a -> ParsecT String () m a
forall a b. (a -> b) -> a -> b
$ SourcePos -> a
f2 SourcePos
c
    delegate Bool
True  (Right SourcePos -> ParsecT String () m a
f2) SourcePos
c = SourcePos -> ParsecT String () m a
f2 SourcePos
c
    delegate Bool
_     (Left SourcePos -> a
_)   SourcePos
c = SourcePos -> String -> ParsecT String () m a
forall (m :: * -> *) a.
CompileErrorM m =>
SourcePos -> String -> ParserE m a
parseErrorM SourcePos
c (String -> ParsecT String () m a)
-> String -> ParsecT 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 SourcePos -> ParsecT String () m a
_)  SourcePos
c = SourcePos -> String -> ParsecT String () m a
forall (m :: * -> *) a.
CompileErrorM m =>
SourcePos -> String -> ParserE m a
parseErrorM SourcePos
c (String -> ParsecT String () m a)
-> String -> ParsecT 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 []"