{- -----------------------------------------------------------------------------
Copyright 2019-2021,2023 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 CompilerCxx.LanguageModule (
  LanguageModule(..),
  PrivateSource(..),
  compileLanguageModule,
  compileModuleMain,
  compileTestsModule,
) where

import Control.Monad (foldM,foldM_,when)
import Data.List (intercalate,nub)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Base.CompilerError
import Compilation.CompilerState
import Compilation.ProcedureContext (ExprMap)
import CompilerCxx.CxxFiles
import CompilerCxx.Naming
import Module.CompileMetadata (CategorySpec(..))
import Types.DefinedCategory
import Types.Procedure
import Types.TypeCategory
import Types.TypeInstance


data LanguageModule c =
  LanguageModule {
    forall c. LanguageModule c -> Set Namespace
lmPublicNamespaces :: Set.Set Namespace,
    forall c. LanguageModule c -> Set Namespace
lmPrivateNamespaces :: Set.Set Namespace,
    forall c. LanguageModule c -> Set Namespace
lmLocalNamespaces :: Set.Set Namespace,
    forall c. LanguageModule c -> [AnyCategory c]
lmPublicDeps :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPrivateDeps :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPublicTestingDeps :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPrivateTestingDeps :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPublicLocal :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPrivateLocal :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPublicTestingLocal :: [AnyCategory c],
    forall c. LanguageModule c -> [AnyCategory c]
lmPrivateTestingLocal :: [AnyCategory c],
    forall c. LanguageModule c -> [CategoryName]
lmStreamlined :: [CategoryName],
    forall c. LanguageModule c -> ExprMap c
lmExprMap :: ExprMap c,
    forall c. LanguageModule c -> CategoryMap c
lmEmptyCategories :: CategoryMap c
  }

data PrivateSource c =
  PrivateSource {
    forall c. PrivateSource c -> Namespace
psNamespace :: Namespace,
    forall c. PrivateSource c -> Bool
psTesting :: Bool,
    forall c. PrivateSource c -> [AnyCategory c]
psCategory :: [AnyCategory c],
    forall c. PrivateSource c -> [DefinedCategory c]
psDefine :: [DefinedCategory c]
  }

compileLanguageModule :: (Ord c, Show c, CollectErrorsM m) =>
  LanguageModule c -> Map.Map CategoryName (CategorySpec c) ->
  [PrivateSource c] -> m [CxxOutput]
compileLanguageModule :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
LanguageModule c
-> Map CategoryName (CategorySpec c)
-> [PrivateSource c]
-> m [CxxOutput]
compileLanguageModule (LanguageModule Set Namespace
ns0 Set Namespace
ns1 Set Namespace
ns2 [AnyCategory c]
cs0 [AnyCategory c]
ps0 [AnyCategory c]
tc0 [AnyCategory c]
tp0 [AnyCategory c]
cs1 [AnyCategory c]
ps1 [AnyCategory c]
tc1 [AnyCategory c]
tp1 [CategoryName]
ss ExprMap c
em CategoryMap c
cm0) Map CategoryName (CategorySpec c)
sm [PrivateSource c]
xa = do
  let dm :: Map CategoryName [DefinedCategory c]
dm = forall {c}.
[DefinedCategory c] -> Map CategoryName [DefinedCategory c]
mapDefByName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. PrivateSource c -> [DefinedCategory c]
psDefine [PrivateSource c]
xa
  forall {m :: * -> *} {a} {a}.
(CollectErrorsM m, Show a, Show a) =>
Map CategoryName [DefinedCategory a]
-> Set CategoryName -> Set CategoryName -> [AnyCategory a] -> m ()
checkDefined Map CategoryName [DefinedCategory c]
dm Set CategoryName
extensions Set CategoryName
allExternal forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall c. AnyCategory c -> Bool
isValueConcrete ([AnyCategory c]
cs1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ps1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tc1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tp1)
  forall {m :: * -> *} {a}. (ErrorContextM m, Show a) => [a] -> m ()
checkSupefluous forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ Set CategoryName
extensions forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set CategoryName
ca
  CategoryMap c
tmPublic         <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
cm0             [[AnyCategory c]
cs0,[AnyCategory c]
cs1]
  CategoryMap c
tmPrivate        <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
tmPublic        [[AnyCategory c]
ps0,[AnyCategory c]
ps1]
  CategoryMap c
tmPublicTesting  <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
tmPublic        [[AnyCategory c]
tc0,[AnyCategory c]
tc1]
  CategoryMap c
tmPrivateTesting <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
tmPublicTesting [[AnyCategory c]
ps0,[AnyCategory c]
tp0,[AnyCategory c]
ps1,[AnyCategory c]
tp1]
  [CxxOutput]
xxInterfaces <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (f :: * -> *) a.
(CollectErrorsM m, Foldable f) =>
f (m a) -> m [a]
collectAllM forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Bool -> Set Namespace -> AnyCategory c -> m [CxxOutput]
generateNativeInterface Bool
False Set Namespace
nsPublic)  (forall {c}. [AnyCategory c] -> [AnyCategory c]
onlyNativeInterfaces [AnyCategory c]
cs1) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Bool -> Set Namespace -> AnyCategory c -> m [CxxOutput]
generateNativeInterface Bool
False Set Namespace
nsPrivate) (forall {c}. [AnyCategory c] -> [AnyCategory c]
onlyNativeInterfaces [AnyCategory c]
ps1) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Bool -> Set Namespace -> AnyCategory c -> m [CxxOutput]
generateNativeInterface Bool
True  Set Namespace
nsPublic)  (forall {c}. [AnyCategory c] -> [AnyCategory c]
onlyNativeInterfaces [AnyCategory c]
tc1) forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Bool -> Set Namespace -> AnyCategory c -> m [CxxOutput]
generateNativeInterface Bool
True  Set Namespace
nsPrivate) (forall {c}. [AnyCategory c] -> [AnyCategory c]
onlyNativeInterfaces [AnyCategory c]
tp1)
  [CxxOutput]
xxPrivate <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *}.
CollectErrorsM m =>
CategoryMap c -> CategoryMap c -> PrivateSource c -> m [CxxOutput]
compilePrivate CategoryMap c
tmPrivate CategoryMap c
tmPrivateTesting) [PrivateSource c]
xa
  [CxxOutput]
xxStreamlined <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *}.
CollectErrorsM m =>
CategoryMap c -> CategoryMap c -> CategoryName -> m [CxxOutput]
streamlined CategoryMap c
tmPrivate CategoryMap c
tmPrivateTesting) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a]
nub [CategoryName]
ss
  let allFiles :: [CxxOutput]
allFiles = [CxxOutput]
xxInterfaces forall a. [a] -> [a] -> [a]
++ [CxxOutput]
xxPrivate forall a. [a] -> [a] -> [a]
++ [CxxOutput]
xxStreamlined
  [([Char], Namespace)] -> m ()
noDuplicateFiles forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\CxxOutput
f -> (CxxOutput -> [Char]
coFilename CxxOutput
f,CxxOutput -> Namespace
coNamespace CxxOutput
f)) [CxxOutput]
allFiles
  forall (m :: * -> *) a. Monad m => a -> m a
return [CxxOutput]
allFiles where
    nsPublic :: Set Namespace
nsPublic  = Set Namespace
ns0 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Namespace
ns2
    nsPrivate :: Set Namespace
nsPrivate = Set Namespace
ns1 forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set Namespace
nsPublic
    extensions :: Set CategoryName
extensions = forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName]
ss
    allExternal :: Set CategoryName
allExternal = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set CategoryName
extensions,forall k a. Map k a -> Set k
Map.keysSet Map CategoryName (CategorySpec c)
sm]
    testingCats :: Set CategoryName
testingCats = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> [a] -> [b]
map forall c. AnyCategory c -> CategoryName
getCategoryName [AnyCategory c]
tc1) forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map forall c. AnyCategory c -> CategoryName
getCategoryName [AnyCategory c]
tp1)
    onlyNativeInterfaces :: [AnyCategory c] -> [AnyCategory c]
onlyNativeInterfaces = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CategoryName
extensions) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. AnyCategory c -> CategoryName
getCategoryName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. AnyCategory c -> Bool
isValueConcrete)
    localCats :: Set CategoryName
localCats = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. AnyCategory c -> CategoryName
getCategoryName forall a b. (a -> b) -> a -> b
$ [AnyCategory c]
cs1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ps1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tc1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tp1
    streamlined :: CategoryMap c -> CategoryMap c -> CategoryName -> m [CxxOutput]
streamlined CategoryMap c
tm0 CategoryMap c
tm2 CategoryName
n = do
      forall {f :: * -> *} {a} {a}.
(Ord a, ErrorContextM f, Show a, Show a) =>
Set a -> [a] -> a -> f ()
checkLocal Set CategoryName
localCats ([] :: [String]) CategoryName
n
      let testing :: Bool
testing = CategoryName
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CategoryName
testingCats
      let tm :: CategoryMap c
tm = if Bool
testing then CategoryMap c
tm2 else CategoryMap c
tm0
      ([c]
_,AnyCategory c
t) <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getConcreteCategory CategoryMap c
tm ([],CategoryName
n)
      let ctx :: FileContext c
ctx = forall c.
Bool
-> CategoryMap c -> Set Namespace -> ExprMap c -> FileContext c
FileContext Bool
testing CategoryMap c
tm Set Namespace
nsPrivate forall k a. Map k a
Map.empty
      let spec :: CategorySpec c
spec = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall c.
[c] -> [ValueRefine c] -> [ValueDefine c] -> CategorySpec c
CategorySpec [] [] []) (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
t) Map CategoryName (CategorySpec c)
sm
      forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
FileContext c -> AnyCategory c -> CategorySpec c -> m [CxxOutput]
generateStreamlinedExtension FileContext c
ctx AnyCategory c
t CategorySpec c
spec
    compilePrivate :: CategoryMap c -> CategoryMap c -> PrivateSource c -> m [CxxOutput]
compilePrivate CategoryMap c
tmPrivate CategoryMap c
tmTesting (PrivateSource Namespace
ns3 Bool
testing [AnyCategory c]
cs2 [DefinedCategory c]
ds) = do
      let tm :: CategoryMap c
tm = if Bool
testing
                  then CategoryMap c
tmTesting
                  else CategoryMap c
tmPrivate
      let cs :: Set CategoryName
cs = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. AnyCategory c -> CategoryName
getCategoryName forall a b. (a -> b) -> a -> b
$ if Bool
testing
                                                       then [AnyCategory c]
cs2 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
cs1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ps1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tc1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tp1
                                                       else [AnyCategory c]
cs2 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
cs1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ps1
      CategoryMap c
tm' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
tm [AnyCategory c]
cs2
      let ctx :: FileContext c
ctx = forall c.
Bool
-> CategoryMap c -> Set Namespace -> ExprMap c -> FileContext c
FileContext Bool
testing CategoryMap c
tm' (Namespace
ns3 forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set Namespace
nsPrivate) ExprMap c
em
      forall {m :: * -> *} {c}.
(CollectErrorsM m, Show c) =>
[DefinedCategory c] -> Set CategoryName -> m ()
checkLocals [DefinedCategory c]
ds forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall c. CategoryMap c -> Map CategoryName (AnyCategory c)
cmAvailable CategoryMap c
tm'
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
testing forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a} {a}.
(CollectErrorsM m, Show a, Show a) =>
[DefinedCategory a] -> [AnyCategory a] -> m ()
checkTests [DefinedCategory c]
ds ([AnyCategory c]
cs1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ps1)
      let dm :: Map CategoryName [DefinedCategory c]
dm = forall {c}.
[DefinedCategory c] -> Map CategoryName [DefinedCategory c]
mapDefByName [DefinedCategory c]
ds
      forall {m :: * -> *} {a} {a}.
(CollectErrorsM m, Show a, Show a) =>
Map CategoryName [DefinedCategory a]
-> Set CategoryName -> Set CategoryName -> [AnyCategory a] -> m ()
checkDefined Map CategoryName [DefinedCategory c]
dm forall a. Set a
Set.empty forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall c. AnyCategory c -> Bool
isValueConcrete [AnyCategory c]
cs2
      [CxxOutput]
xxInterfaces <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
Bool -> Set Namespace -> AnyCategory c -> m [CxxOutput]
generateNativeInterface Bool
testing Set Namespace
nsPrivate) (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. AnyCategory c -> Bool
isValueConcrete) [AnyCategory c]
cs2)
      [CxxOutput]
xxConcrete   <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m [b]
mapCompilerM (forall {m :: * -> *} {c}.
(Show c, CollectErrorsM m, Ord c) =>
Set CategoryName
-> FileContext c -> DefinedCategory c -> m [CxxOutput]
generateConcrete Set CategoryName
cs FileContext c
ctx) [DefinedCategory c]
ds
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [CxxOutput]
xxInterfaces forall a. [a] -> [a] -> [a]
++ [CxxOutput]
xxConcrete
    generateConcrete :: Set CategoryName
-> FileContext c -> DefinedCategory c -> m [CxxOutput]
generateConcrete Set CategoryName
cs (FileContext Bool
testing CategoryMap c
tm Set Namespace
ns ExprMap c
em2) DefinedCategory c
d = do
      AnyCategory c
t <- forall {m :: * -> *} {c}.
(Show c, CollectErrorsM m) =>
Set CategoryName
-> CategoryMap c -> DefinedCategory c -> m (AnyCategory c)
getCategoryDecl Set CategoryName
cs CategoryMap c
tm DefinedCategory c
d
      let ctx :: FileContext c
ctx = forall c.
Bool
-> CategoryMap c -> Set Namespace -> ExprMap c -> FileContext c
FileContext Bool
testing CategoryMap c
tm Set Namespace
ns ExprMap c
em2
      forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
FileContext c
-> (AnyCategory c, DefinedCategory c) -> m [CxxOutput]
generateNativeConcrete FileContext c
ctx (AnyCategory c
t,DefinedCategory c
d)
    getCategoryDecl :: Set CategoryName
-> CategoryMap c -> DefinedCategory c -> m (AnyCategory c)
getCategoryDecl Set CategoryName
cs CategoryMap c
tm DefinedCategory c
d = do
      forall {f :: * -> *} {a} {a}.
(Ord a, ErrorContextM f, Show a, Show a) =>
Set a -> [a] -> a -> f ()
checkLocal Set CategoryName
cs (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory c
d) (forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory c
d)
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> ([c], CategoryName) -> m ([c], AnyCategory c)
getConcreteCategory CategoryMap c
tm (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory c
d,forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory c
d)
    mapDefByName :: [DefinedCategory c] -> Map CategoryName [DefinedCategory c]
mapDefByName = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\DefinedCategory c
d -> (forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory c
d,[DefinedCategory c
d]))
    ca :: Set CategoryName
ca = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. AnyCategory c -> CategoryName
getCategoryName forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall c. AnyCategory c -> Bool
isValueConcrete ([AnyCategory c]
cs1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
ps1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tc1 forall a. [a] -> [a] -> [a]
++ [AnyCategory c]
tp1)
    checkLocals :: [DefinedCategory c] -> Set CategoryName -> m ()
checkLocals [DefinedCategory c]
ds Set CategoryName
tm = forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (\DefinedCategory c
d -> forall {f :: * -> *} {a} {a}.
(Ord a, ErrorContextM f, Show a, Show a) =>
Set a -> [a] -> a -> f ()
checkLocal Set CategoryName
tm (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory c
d) (forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory c
d)) [DefinedCategory c]
ds
    checkLocal :: Set a -> [a] -> a -> f ()
checkLocal Set a
cs2 [a]
c a
n =
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ a
n forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
cs2) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM ([Char]
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
n forall a. [a] -> [a] -> [a]
++
                        forall a. Show a => [a] -> [Char]
formatFullContextBrace [a]
c forall a. [a] -> [a] -> [a]
++
                        [Char]
" does not correspond to a visible category in this module")
    checkTests :: [DefinedCategory a] -> [AnyCategory a] -> m ()
checkTests [DefinedCategory a]
ds [AnyCategory a]
ps = do
      let pa :: Map CategoryName [a]
pa = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\AnyCategory a
c -> (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
c,forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory a
c)) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall c. AnyCategory c -> Bool
isValueConcrete [AnyCategory a]
ps
      forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {a} {a}.
(ErrorContextM m, Show a, Show a) =>
Map CategoryName [a] -> DefinedCategory a -> m ()
checkTest Map CategoryName [a]
pa) [DefinedCategory a]
ds
    checkTest :: Map CategoryName [a] -> DefinedCategory a -> m ()
checkTest Map CategoryName [a]
pa DefinedCategory a
d =
      case forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory a
d forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName [a]
pa of
           Maybe [a]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Just [a]
c  ->
             forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM ([Char]
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory a
d) forall a. [a] -> [a] -> [a]
++
                            forall a. Show a => [a] -> [Char]
formatFullContextBrace (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory a
d) forall a. [a] -> [a] -> [a]
++
                            [Char]
" was not declared as $TestsOnly$" forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> [Char]
formatFullContextBrace [a]
c)
    checkDefined :: Map CategoryName [DefinedCategory a]
-> Set CategoryName -> Set CategoryName -> [AnyCategory a] -> m ()
checkDefined Map CategoryName [DefinedCategory a]
dm Set CategoryName
ext Set CategoryName
extAll = forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (forall {m :: * -> *} {a} {a}.
(Show a, Show a, CollectErrorsM m) =>
Map CategoryName [DefinedCategory a]
-> Set CategoryName -> Set CategoryName -> AnyCategory a -> m ()
checkSingle Map CategoryName [DefinedCategory a]
dm Set CategoryName
ext Set CategoryName
extAll)
    checkSingle :: Map CategoryName [DefinedCategory a]
-> Set CategoryName -> Set CategoryName -> AnyCategory a -> m ()
checkSingle Map CategoryName [DefinedCategory a]
dm Set CategoryName
ext Set CategoryName
extAll AnyCategory a
t =
      case (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CategoryName
ext,forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CategoryName
extAll,forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CategoryName [DefinedCategory a]
dm) of
           (Bool
False,Bool
False,Just [DefinedCategory a
_]) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           (Bool
True,Bool
_,Maybe [DefinedCategory a]
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           (Bool
False,Bool
_,Maybe [DefinedCategory a]
Nothing) ->
             forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM ([Char]
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t) forall a. [a] -> [a] -> [a]
++
                             forall a. Show a => [a] -> [Char]
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory a
t) forall a. [a] -> [a] -> [a]
++
                             [Char]
" has not been defined or declared external")
           (Bool
_,Bool
True,Just [DefinedCategory a
d]) ->
             forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM ([Char]
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t) forall a. [a] -> [a] -> [a]
++
                             forall a. Show a => [a] -> [Char]
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory a
t) forall a. [a] -> [a] -> [a]
++
                             [Char]
" was declared external but is also defined at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> [Char]
formatFullContext (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory a
d))
           (Bool
_,Bool
_,Just [DefinedCategory a]
ds) ->
             ([Char]
"Category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory a
t) forall a. [a] -> [a] -> [a]
++
              forall a. Show a => [a] -> [Char]
formatFullContextBrace (forall c. AnyCategory c -> [c]
getCategoryContext AnyCategory a
t) forall a. [a] -> [a] -> [a]
++
              [Char]
" is defined " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [DefinedCategory a]
ds) forall a. [a] -> [a] -> [a]
++ [Char]
" times") forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a -> m a
!!>
                forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (\DefinedCategory a
d -> forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ [Char]
"Defined at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> [Char]
formatFullContext (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory a
d)) [DefinedCategory a]
ds
    checkSupefluous :: [a] -> m ()
checkSupefluous [a]
es2
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
es2 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ [Char]
"External categories either not concrete or not present: " forall a. [a] -> [a] -> [a]
++
                                     forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [a]
es2)
    noDuplicateFiles :: [([Char], Namespace)] -> m ()
noDuplicateFiles = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ forall {m :: * -> *} {b}.
(Ord b, ErrorContextM m, Show b) =>
Set ([Char], b) -> ([Char], b) -> m (Set ([Char], b))
checkFileUsed forall a. Set a
Set.empty
    checkFileUsed :: Set ([Char], b) -> ([Char], b) -> m (Set ([Char], b))
checkFileUsed Set ([Char], b)
used ([Char]
f,b
ns3) = do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (([Char]
f,b
ns3) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ([Char], b)
used) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ [Char]
"Filename " forall a. [a] -> [a] -> [a]
++ [Char]
f forall a. [a] -> [a] -> [a]
++ [Char]
" in namespace " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show b
ns3 forall a. [a] -> [a] -> [a]
++
                         [Char]
" was already generated (internal compiler error)"
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([Char]
f,b
ns3) forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set ([Char], b)
used

compileTestsModule :: (Ord c, Show c, CollectErrorsM m) =>
  LanguageModule c -> Namespace -> [String] -> Maybe ([c],TypeInstance) -> [AnyCategory c] ->
  [DefinedCategory c] -> [TestProcedure c] -> m ([CxxOutput],CxxOutput,[(FunctionName,[c])])
compileTestsModule :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
LanguageModule c
-> Namespace
-> [[Char]]
-> Maybe ([c], TypeInstance)
-> [AnyCategory c]
-> [DefinedCategory c]
-> [TestProcedure c]
-> m ([CxxOutput], CxxOutput, [(FunctionName, [c])])
compileTestsModule LanguageModule c
cm Namespace
ns [[Char]]
args Maybe ([c], TypeInstance)
t [AnyCategory c]
cs [DefinedCategory c]
ds [TestProcedure c]
ts = do
  let xs :: PrivateSource c
xs = PrivateSource {
      psNamespace :: Namespace
psNamespace = Namespace
ns,
      psTesting :: Bool
psTesting = Bool
True,
      psCategory :: [AnyCategory c]
psCategory = [AnyCategory c]
cs,
      psDefine :: [DefinedCategory c]
psDefine = [DefinedCategory c]
ds
    }
  [CxxOutput]
xx <- forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
LanguageModule c
-> Map CategoryName (CategorySpec c)
-> [PrivateSource c]
-> m [CxxOutput]
compileLanguageModule LanguageModule c
cm forall k a. Map k a
Map.empty [PrivateSource c
xs]
  (CxxOutput
main,[(FunctionName, [c])]
fs) <- forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
LanguageModule c
-> [[Char]]
-> Maybe ([c], TypeInstance)
-> PrivateSource c
-> [TestProcedure c]
-> m (CxxOutput, [(FunctionName, [c])])
compileTestMain LanguageModule c
cm [[Char]]
args Maybe ([c], TypeInstance)
t PrivateSource c
xs [TestProcedure c]
ts
  forall (m :: * -> *) a. Monad m => a -> m a
return ([CxxOutput]
xx,CxxOutput
main,[(FunctionName, [c])]
fs)

compileTestMain :: (Ord c, Show c, CollectErrorsM m) =>
  LanguageModule c -> [String] -> Maybe ([c],TypeInstance) -> PrivateSource c -> [TestProcedure c] ->
  m (CxxOutput,[(FunctionName,[c])])
compileTestMain :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
LanguageModule c
-> [[Char]]
-> Maybe ([c], TypeInstance)
-> PrivateSource c
-> [TestProcedure c]
-> m (CxxOutput, [(FunctionName, [c])])
compileTestMain (LanguageModule Set Namespace
ns0 Set Namespace
ns1 Set Namespace
ns2 [AnyCategory c]
cs0 [AnyCategory c]
ps0 [AnyCategory c]
tc0 [AnyCategory c]
tp0 [AnyCategory c]
cs1 [AnyCategory c]
ps1 [AnyCategory c]
tc1 [AnyCategory c]
tp1 [CategoryName]
_ ExprMap c
em CategoryMap c
cm0) [[Char]]
args Maybe ([c], TypeInstance)
t PrivateSource c
ts2 [TestProcedure c]
tests = do
  CategoryMap c
tm' <- m (CategoryMap c)
tm
  (CompiledData Set CategoryName
req Set [Char]
traces [[Char]]
main) <- forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
CategoryMap c
-> ExprMap c
-> [[Char]]
-> Maybe ([c], TypeInstance)
-> [TestProcedure c]
-> m (CompiledData [[Char]])
generateTestFile CategoryMap c
tm' ExprMap c
em [[Char]]
args Maybe ([c], TypeInstance)
t [TestProcedure c]
tests
  let output :: CxxOutput
output = Maybe CategoryName
-> [Char]
-> Namespace
-> Set Namespace
-> Set CategoryName
-> Set [Char]
-> [[Char]]
-> CxxOutput
CxxOutput forall a. Maybe a
Nothing [Char]
testFilename Namespace
NoNamespace (forall c. PrivateSource c -> Namespace
psNamespace PrivateSource c
ts2 forall a. Ord a => a -> Set a -> Set a
`Set.insert` forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Namespace
ns0,Set Namespace
ns1,Set Namespace
ns2]) Set CategoryName
req Set [Char]
traces [[Char]]
main
  let tests' :: [(FunctionName, [c])]
tests' = forall a b. (a -> b) -> [a] -> [b]
map (\TestProcedure c
t2 -> (forall c. TestProcedure c -> FunctionName
tpName TestProcedure c
t2,forall c. TestProcedure c -> [c]
tpContext TestProcedure c
t2)) [TestProcedure c]
tests
  forall (m :: * -> *) a. Monad m => a -> m a
return (CxxOutput
output,[(FunctionName, [c])]
tests') where
  tm :: m (CategoryMap c)
tm = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
cm0 [[AnyCategory c]
cs0,[AnyCategory c]
cs1,[AnyCategory c]
ps0,[AnyCategory c]
ps1,[AnyCategory c]
tc0,[AnyCategory c]
tp0,[AnyCategory c]
tc1,[AnyCategory c]
tp1,forall c. PrivateSource c -> [AnyCategory c]
psCategory PrivateSource c
ts2]

compileModuleMain :: (Ord c, Show c, CollectErrorsM m) =>
  LanguageModule c -> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput
compileModuleMain :: forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
LanguageModule c
-> [PrivateSource c] -> CategoryName -> FunctionName -> m CxxOutput
compileModuleMain (LanguageModule Set Namespace
ns0 Set Namespace
ns1 Set Namespace
ns2 [AnyCategory c]
cs0 [AnyCategory c]
ps0 [AnyCategory c]
_ [AnyCategory c]
_ [AnyCategory c]
cs1 [AnyCategory c]
ps1 [AnyCategory c]
_ [AnyCategory c]
_ [CategoryName]
_ ExprMap c
em CategoryMap c
cm0) [PrivateSource c]
xa CategoryName
n FunctionName
f = do
  let resolved :: [DefinedCategory c]
resolved = forall a. (a -> Bool) -> [a] -> [a]
filter (\DefinedCategory c
d -> forall c. DefinedCategory c -> CategoryName
dcName DefinedCategory c
d forall a. Eq a => a -> a -> Bool
== CategoryName
n) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. PrivateSource c -> [DefinedCategory c]
psDefine forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. PrivateSource c -> Bool
psTesting) [PrivateSource c]
xa
  forall {m :: * -> *} {a}.
(CollectErrorsM m, Show a) =>
[DefinedCategory a] -> m ()
reconcile [DefinedCategory c]
resolved
  CategoryMap c
tm' <- m (CategoryMap c)
tm
  let cs :: [AnyCategory c]
cs = forall a. (a -> Bool) -> [a] -> [a]
filter (\AnyCategory c
c -> forall c. AnyCategory c -> CategoryName
getCategoryName AnyCategory c
c forall a. Eq a => a -> a -> Bool
== CategoryName
n) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall c. PrivateSource c -> [AnyCategory c]
psCategory [PrivateSource c]
xa
  CategoryMap c
tm'' <- forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
tm' [AnyCategory c]
cs
  (Namespace
ns,[[Char]]
main) <- forall c (m :: * -> *).
(Ord c, Show c, CollectErrorsM m) =>
CategoryMap c
-> ExprMap c
-> CategoryName
-> FunctionName
-> m (Namespace, [[Char]])
generateMainFile CategoryMap c
tm'' ExprMap c
em CategoryName
n FunctionName
f
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe CategoryName
-> [Char]
-> Namespace
-> Set Namespace
-> Set CategoryName
-> Set [Char]
-> [[Char]]
-> CxxOutput
CxxOutput forall a. Maybe a
Nothing [Char]
mainFilename Namespace
NoNamespace (Namespace
ns forall a. Ord a => a -> Set a -> Set a
`Set.insert` forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Namespace
ns0,Set Namespace
ns1,Set Namespace
ns2]) (forall a. Ord a => [a] -> Set a
Set.fromList [CategoryName
n]) forall a. Set a
Set.empty [[Char]]
main where
    tm :: m (CategoryMap c)
tm = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall c (m :: * -> *).
(Show c, CollectErrorsM m) =>
CategoryMap c -> [AnyCategory c] -> m (CategoryMap c)
includeNewTypes CategoryMap c
cm0 [[AnyCategory c]
cs0,[AnyCategory c]
cs1,[AnyCategory c]
ps0,[AnyCategory c]
ps1]
    reconcile :: [DefinedCategory a] -> m ()
reconcile [DefinedCategory a
_] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    reconcile []  = forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ [Char]
"No matches for main category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show CategoryName
n forall a. [a] -> [a] -> [a]
++ [Char]
" ($TestsOnly$ sources excluded)"
    reconcile [DefinedCategory a]
ds  =
      [Char]
"Multiple matches for main category " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show CategoryName
n forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a -> m a
!!>
        forall (m :: * -> *) a b.
CollectErrorsM m =>
(a -> m b) -> [a] -> m ()
mapCompilerM_ (\DefinedCategory a
d -> forall (m :: * -> *) a. ErrorContextM m => [Char] -> m a
compilerErrorM forall a b. (a -> b) -> a -> b
$ [Char]
"Defined at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => [a] -> [Char]
formatFullContext (forall c. DefinedCategory c -> [c]
dcContext DefinedCategory a
d)) [DefinedCategory a]
ds