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

{-# LANGUAGE FlexibleInstances #-}

module Parser.DefinedCategory (
) where

import Prelude hiding (pi)

import Base.CompilerError
import Parser.Common
import Parser.Pragma (autoPragma)
import Parser.Procedure ()
import Parser.TextParser hiding (hidden)
import Parser.TypeCategory
import Parser.TypeInstance ()
import Types.DefinedCategory
import Types.Procedure
import Types.TypeCategory
import Types.TypeInstance


instance ParseFromSource (DefinedCategory SourceContext) where
  sourceParser :: TextParser (DefinedCategory SourceContext)
sourceParser = forall a. String -> TextParser a -> TextParser a
labeled String
"defined concrete category" forall a b. (a -> b) -> a -> b
$ do
    SourceContext
c <- TextParser SourceContext
getSourceContext
    TextParser ()
kwDefine
    CategoryName
n <- forall a. ParseFromSource a => TextParser a
sourceParser
    forall a. TextParser a -> TextParser a
sepAfter (String -> TextParser ()
string_ String
"{")
    [PragmaDefined SourceContext]
pragmas <- forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
singlePragma TextParser ()
optionalSpace
    ([ValueRefine SourceContext]
ds,[ValueDefine SourceContext]
rs) <- ParsecT
  CompilerMessage
  String
  Identity
  ([ValueRefine SourceContext], [ValueDefine SourceContext])
parseRefinesDefines
    ([DefinedMember SourceContext]
ms,[ExecutableProcedure SourceContext]
ps,[ScopedFunction SourceContext]
fs) <- CategoryName
-> TextParser
     ([DefinedMember SourceContext],
      [ExecutableProcedure SourceContext],
      [ScopedFunction SourceContext])
parseMemberProcedureFunction CategoryName
n
    forall a. TextParser a -> TextParser a
sepAfter (String -> TextParser ()
string_ String
"}")
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> CategoryName
-> [PragmaDefined c]
-> [ValueRefine c]
-> [ValueDefine c]
-> [DefinedMember c]
-> [ExecutableProcedure c]
-> [ScopedFunction c]
-> DefinedCategory c
DefinedCategory [SourceContext
c] CategoryName
n [PragmaDefined SourceContext]
pragmas [ValueRefine SourceContext]
ds [ValueDefine SourceContext]
rs [DefinedMember SourceContext]
ms [ExecutableProcedure SourceContext]
ps [ScopedFunction SourceContext]
fs
    where
      parseRefinesDefines :: ParsecT
  CompilerMessage
  String
  Identity
  ([ValueRefine SourceContext], [ValueDefine SourceContext])
parseRefinesDefines = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a b.
(Foldable f, Monoid a, Monoid b) =>
f (a, b) -> (a, b)
merge2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy ParsecT
  CompilerMessage
  String
  Identity
  ([ValueRefine SourceContext], [ValueDefine SourceContext])
refineOrDefine TextParser ()
optionalSpace
      singlePragma :: ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
singlePragma = ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
readOnly forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
readOnlyExcept forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
hidden forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
flatCleanup
      flatCleanup :: ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
flatCleanup = forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"FlatCleanup" forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall {c}.
c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt where
        parseAt :: c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt c
c = do
          VariableName
v <- forall a. String -> TextParser a -> TextParser a
labeled String
"variable name" forall a. ParseFromSource a => TextParser a
sourceParser
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> VariableName -> PragmaDefined c
FlatCleanup [c
c] VariableName
v
      readOnly :: ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
readOnly = forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"ReadOnly" forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall {c}.
c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt where
        parseAt :: c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt c
c = do
          [VariableName]
vs <- forall a. String -> TextParser a -> TextParser a
labeled String
"variable names" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy forall a. ParseFromSource a => TextParser a
sourceParser (forall a. TextParser a -> TextParser a
sepAfter forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
",")
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> [VariableName] -> PragmaDefined c
MembersReadOnly [c
c] [VariableName]
vs
      readOnlyExcept :: ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
readOnlyExcept = forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"ReadOnlyExcept" forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall {c}.
c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt where
        parseAt :: c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt c
c = do
          [VariableName]
vs <- forall a. String -> TextParser a -> TextParser a
labeled String
"variable names" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy forall a. ParseFromSource a => TextParser a
sourceParser (forall a. TextParser a -> TextParser a
sepAfter forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
",")
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> [VariableName] -> PragmaDefined c
MembersReadOnlyExcept [c
c] [VariableName]
vs
      hidden :: ParsecT
  CompilerMessage String Identity (PragmaDefined SourceContext)
hidden = forall a.
String
-> Either (SourceContext -> a) (SourceContext -> TextParser a)
-> TextParser a
autoPragma String
"Hidden" forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall {c}.
c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt where
        parseAt :: c -> ParsecT CompilerMessage String Identity (PragmaDefined c)
parseAt c
c = do
          [VariableName]
vs <- forall a. String -> TextParser a -> TextParser a
labeled String
"variable names" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
sepBy forall a. ParseFromSource a => TextParser a
sourceParser (forall a. TextParser a -> TextParser a
sepAfter forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string String
",")
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c. [c] -> [VariableName] -> PragmaDefined c
MembersHidden [c
c] [VariableName]
vs
      refineOrDefine :: ParsecT
  CompilerMessage
  String
  Identity
  ([ValueRefine SourceContext], [ValueDefine SourceContext])
refineOrDefine = forall a. String -> TextParser a -> TextParser a
labeled String
"refine or define" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
(Functor m, Monad m) =>
m a -> m ([a], [b])
put12 TextParser (ValueRefine SourceContext)
singleRefine forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) b a.
(Functor m, Monad m) =>
m b -> m ([a], [b])
put22 TextParser (ValueDefine SourceContext)
singleDefine

instance ParseFromSource (DefinedMember SourceContext) where
  sourceParser :: TextParser (DefinedMember SourceContext)
sourceParser = forall a. String -> TextParser a -> TextParser a
labeled String
"defined member" forall a b. (a -> b) -> a -> b
$ do
    SourceContext
c <- TextParser SourceContext
getSourceContext
    (SymbolScope
s,ValueType
t) <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT CompilerMessage String Identity (SymbolScope, ValueType)
parseType
    VariableName
n <- forall a. ParseFromSource a => TextParser a
sourceParser
    Maybe (Expression SourceContext)
e <- if SymbolScope
s forall a. Eq a => a -> a -> Bool
== SymbolScope
ValueScope
            then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            else TextParser (Maybe (Expression SourceContext))
parseInit
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall c.
[c]
-> SymbolScope
-> ValueType
-> VariableName
-> Maybe (Expression c)
-> DefinedMember c
DefinedMember [SourceContext
c] SymbolScope
s ValueType
t VariableName
n Maybe (Expression SourceContext)
e
    where
      parseInit :: TextParser (Maybe (Expression SourceContext))
parseInit = forall a. String -> TextParser a -> TextParser a
labeled String
"member initializer" forall a b. (a -> b) -> a -> b
$ do
        TextParser ()
assignOperator
        Expression SourceContext
e <- forall a. ParseFromSource a => TextParser a
sourceParser
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Expression SourceContext
e
      parseType :: ParsecT CompilerMessage String Identity (SymbolScope, ValueType)
parseType = do
        SymbolScope
s <- TextParser SymbolScope
parseScope
        ValueType
t <- forall a. ParseFromSource a => TextParser a
sourceParser
        forall (m :: * -> *) a. Monad m => a -> m a
return (SymbolScope
s,ValueType
t)

parseMemberProcedureFunction ::
  CategoryName -> TextParser ([DefinedMember SourceContext],
                             [ExecutableProcedure SourceContext],
                             [ScopedFunction SourceContext])
parseMemberProcedureFunction :: CategoryName
-> TextParser
     ([DefinedMember SourceContext],
      [ExecutableProcedure SourceContext],
      [ScopedFunction SourceContext])
parseMemberProcedureFunction CategoryName
n = do
  ([DefinedMember SourceContext]
ms,[ExecutableProcedure SourceContext]
ps,[(ScopedFunction SourceContext, ExecutableProcedure SourceContext)]
fs) <- forall a b c.
TextParser a
-> TextParser b -> TextParser c -> TextParser ([a], [b], [c])
parseAny3 (forall {a}. TextParser a
catchUnscopedType forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall a. ParseFromSource a => TextParser a
sourceParser) forall a. ParseFromSource a => TextParser a
sourceParser TextParser
  (ScopedFunction SourceContext, ExecutableProcedure SourceContext)
singleFunction
  let ps2 :: [ExecutableProcedure SourceContext]
ps2 = [ExecutableProcedure SourceContext]
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(ScopedFunction SourceContext, ExecutableProcedure SourceContext)]
fs
  let fs2 :: [ScopedFunction SourceContext]
fs2 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(ScopedFunction SourceContext, ExecutableProcedure SourceContext)]
fs
  forall (m :: * -> *) a. Monad m => a -> m a
return ([DefinedMember SourceContext]
ms,[ExecutableProcedure SourceContext]
ps2,[ScopedFunction SourceContext]
fs2) where
    singleFunction :: TextParser
  (ScopedFunction SourceContext, ExecutableProcedure SourceContext)
singleFunction = forall a. String -> TextParser a -> TextParser a
labeled String
"function" forall a b. (a -> b) -> a -> b
$ do
      ScopedFunction SourceContext
f <- TextParser SymbolScope
-> TextParser CategoryName
-> TextParser (ScopedFunction SourceContext)
parseScopedFunction TextParser SymbolScope
parseScope (forall (m :: * -> *) a. Monad m => a -> m a
return CategoryName
n)
      forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (forall a. TextParser a -> TextParser a
sepAfter forall a b. (a -> b) -> a -> b
$ String -> TextParser ()
string_ forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction SourceContext
f)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ String
"expected definition of function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction SourceContext
f))
      ExecutableProcedure SourceContext
p <- forall a. String -> TextParser a -> TextParser a
labeled (String
"definition of function " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall c. ScopedFunction c -> FunctionName
sfName ScopedFunction SourceContext
f)) forall a b. (a -> b) -> a -> b
$ forall a. ParseFromSource a => TextParser a
sourceParser
      forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedFunction SourceContext
f,ExecutableProcedure SourceContext
p)
    catchUnscopedType :: TextParser a
catchUnscopedType = forall a. String -> TextParser a -> TextParser a
labeled String
"" forall a b. (a -> b) -> a -> b
$ do
      ValueType
_ <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a. ParseFromSource a => TextParser a
sourceParser :: TextParser ValueType
      forall (m :: * -> *) a. ErrorContextM m => String -> m a
compilerErrorM String
"members must have an explicit @value or @category scope"