{- -----------------------------------------------------------------------------
Copyright 2020-2021 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 (
  autoPragma,
  parsePragmas,
  unknownPragma,
) where

import Control.Monad (when)

import Base.CompilerError
import Parser.Common
import Parser.TextParser


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

unknownPragma :: TextParser a
unknownPragma :: forall a. TextParser a
unknownPragma = do
  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try TextParser ()
pragmaStart
  String
p <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"pragma " forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
" is not supported in this context"

autoPragma :: String -> Either (SourceContext -> a) (SourceContext -> TextParser a) -> TextParser a
autoPragma :: forall a.
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
  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ TextParser ()
pragmaStart forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> TextParser ()
string_ String
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar
  Bool
hasArgs <- (TextParser ()
pragmaArgsStart forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser ()
optionalSpace forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  a
x <- 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 <- forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
asciiChar (String -> TextParser ()
string_ String
"]$")
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
extra) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"content unused by pragma " forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
extra
       TextParser ()
optionalSpace
     else forall a. TextParser a -> TextParser a
sepAfter TextParser ()
pragmaEnd
  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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"pragma " forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
" does not allow arguments using []"
    delegate Bool
_     (Right t -> m a
_)  t
_ = forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"pragma " forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
" requires arguments using []"