{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module FlatBuffers.Internal.Compiler.SemanticAnalysis where

import           Control.Monad                                 ( forM_, join, when )
import           Control.Monad.Except                          ( throwError )
import           Control.Monad.Reader                          ( ReaderT, asks, local, runReaderT )
import           Control.Monad.State                           ( MonadState, State, StateT, evalState, evalStateT, get, mapStateT, modify, put )
import           Control.Monad.Trans                           ( lift )

import           Data.Bits                                     ( (.&.), (.|.), Bits, FiniteBits, bit, finiteBitSize )
import           Data.Coerce                                   ( coerce )
import           Data.Foldable                                 ( asum, find, foldlM, traverse_ )
import qualified Data.Foldable                                 as Foldable
import           Data.Functor                                  ( ($>), (<&>) )
import           Data.Int
import           Data.Ix                                       ( inRange )
import qualified Data.List                                     as List
import           Data.List.NonEmpty                            ( NonEmpty((:|)) )
import qualified Data.List.NonEmpty                            as NE
import           Data.Map.Strict                               ( Map )
import qualified Data.Map.Strict                               as Map
import           Data.Maybe                                    ( catMaybes, fromMaybe, isJust )
import           Data.Monoid                                   ( Sum(..) )
import           Data.Scientific                               ( Scientific )
import qualified Data.Scientific                               as Scientific
import           Data.Set                                      ( Set )
import qualified Data.Set                                      as Set
import           Data.Text                                     ( Text )
import qualified Data.Text                                     as T
import           Data.Traversable                              ( for )
import           Data.Word

import           FlatBuffers.Internal.Compiler.Display         ( Display(..) )
import           FlatBuffers.Internal.Compiler.SyntaxTree      ( FileTree(..), HasMetadata(..), Schema, qualify )
import qualified FlatBuffers.Internal.Compiler.SyntaxTree      as ST
import           FlatBuffers.Internal.Compiler.ValidSyntaxTree
import           FlatBuffers.Internal.Constants
import           FlatBuffers.Internal.Types

import           Text.Read                                     ( readMaybe )


----------------------------------
------- MonadValidation ----------
----------------------------------

-- | A monad that allows short-circuiting when a validation error is found.
--
-- It keeps track of which item is currently being validated, so that when an error
-- happens, we can show the user a better error message with contextual information.
newtype Validation a = Validation
  { Validation a -> ReaderT ValidationState (Either String) a
runValidation :: ReaderT ValidationState (Either String) a
  }
  deriving newtype (a -> Validation b -> Validation a
(a -> b) -> Validation a -> Validation b
(forall a b. (a -> b) -> Validation a -> Validation b)
-> (forall a b. a -> Validation b -> Validation a)
-> Functor Validation
forall a b. a -> Validation b -> Validation a
forall a b. (a -> b) -> Validation a -> Validation b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Validation b -> Validation a
$c<$ :: forall a b. a -> Validation b -> Validation a
fmap :: (a -> b) -> Validation a -> Validation b
$cfmap :: forall a b. (a -> b) -> Validation a -> Validation b
Functor, Functor Validation
a -> Validation a
Functor Validation
-> (forall a. a -> Validation a)
-> (forall a b.
    Validation (a -> b) -> Validation a -> Validation b)
-> (forall a b c.
    (a -> b -> c) -> Validation a -> Validation b -> Validation c)
-> (forall a b. Validation a -> Validation b -> Validation b)
-> (forall a b. Validation a -> Validation b -> Validation a)
-> Applicative Validation
Validation a -> Validation b -> Validation b
Validation a -> Validation b -> Validation a
Validation (a -> b) -> Validation a -> Validation b
(a -> b -> c) -> Validation a -> Validation b -> Validation c
forall a. a -> Validation a
forall a b. Validation a -> Validation b -> Validation a
forall a b. Validation a -> Validation b -> Validation b
forall a b. Validation (a -> b) -> Validation a -> Validation b
forall a b c.
(a -> b -> c) -> Validation a -> Validation b -> Validation c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Validation a -> Validation b -> Validation a
$c<* :: forall a b. Validation a -> Validation b -> Validation a
*> :: Validation a -> Validation b -> Validation b
$c*> :: forall a b. Validation a -> Validation b -> Validation b
liftA2 :: (a -> b -> c) -> Validation a -> Validation b -> Validation c
$cliftA2 :: forall a b c.
(a -> b -> c) -> Validation a -> Validation b -> Validation c
<*> :: Validation (a -> b) -> Validation a -> Validation b
$c<*> :: forall a b. Validation (a -> b) -> Validation a -> Validation b
pure :: a -> Validation a
$cpure :: forall a. a -> Validation a
$cp1Applicative :: Functor Validation
Applicative, Applicative Validation
a -> Validation a
Applicative Validation
-> (forall a b.
    Validation a -> (a -> Validation b) -> Validation b)
-> (forall a b. Validation a -> Validation b -> Validation b)
-> (forall a. a -> Validation a)
-> Monad Validation
Validation a -> (a -> Validation b) -> Validation b
Validation a -> Validation b -> Validation b
forall a. a -> Validation a
forall a b. Validation a -> Validation b -> Validation b
forall a b. Validation a -> (a -> Validation b) -> Validation b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Validation a
$creturn :: forall a. a -> Validation a
>> :: Validation a -> Validation b -> Validation b
$c>> :: forall a b. Validation a -> Validation b -> Validation b
>>= :: Validation a -> (a -> Validation b) -> Validation b
$c>>= :: forall a b. Validation a -> (a -> Validation b) -> Validation b
$cp1Monad :: Applicative Validation
Monad)

data ValidationState = ValidationState
  { ValidationState -> [Ident]
validationStateCurrentContext :: ![Ident]
    -- ^ The thing being validated (e.g. a fully-qualified struct name, or a table field name).
  , ValidationState -> Set AttributeDecl
validationStateAllAttributes  :: !(Set ST.AttributeDecl)
    -- ^ All the attributes declared in all the schemas (including imported ones).
  }

class Monad m => MonadValidation m where
  -- | Start validating an item @a@
  validating :: HasIdent a => a -> m b -> m b
  -- | Clear validation context, i.e. forget which item is currently being validated, if any.
  resetContext :: m a -> m a
  -- | Get the path to the item currently being validated
  getContext :: m [Ident]
  -- | Get a list of all the attributes declared in every loaded schema
  getDeclaredAttributes :: m (Set ST.AttributeDecl)
  -- | Fail validation with a message
  throwErrorMsg :: String -> m a

instance MonadValidation Validation where
  validating :: a -> Validation b -> Validation b
validating a
a (Validation ReaderT ValidationState (Either String) b
v) = ReaderT ValidationState (Either String) b -> Validation b
forall a. ReaderT ValidationState (Either String) a -> Validation a
Validation ((ValidationState -> ValidationState)
-> ReaderT ValidationState (Either String) b
-> ReaderT ValidationState (Either String) b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ValidationState -> ValidationState
addIdent ReaderT ValidationState (Either String) b
v)
    where
      addIdent :: ValidationState -> ValidationState
addIdent (ValidationState [Ident]
ctx Set AttributeDecl
attrs) = [Ident] -> Set AttributeDecl -> ValidationState
ValidationState (a -> Ident
forall a. HasIdent a => a -> Ident
getIdent a
a Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: [Ident]
ctx) Set AttributeDecl
attrs
  resetContext :: Validation a -> Validation a
resetContext (Validation ReaderT ValidationState (Either String) a
v) = ReaderT ValidationState (Either String) a -> Validation a
forall a. ReaderT ValidationState (Either String) a -> Validation a
Validation ((ValidationState -> ValidationState)
-> ReaderT ValidationState (Either String) a
-> ReaderT ValidationState (Either String) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ValidationState -> ValidationState
reset ReaderT ValidationState (Either String) a
v)
    where
      reset :: ValidationState -> ValidationState
reset (ValidationState [Ident]
_ Set AttributeDecl
attrs) = [Ident] -> Set AttributeDecl -> ValidationState
ValidationState [] Set AttributeDecl
attrs
  getContext :: Validation [Ident]
getContext            = ReaderT ValidationState (Either String) [Ident]
-> Validation [Ident]
forall a. ReaderT ValidationState (Either String) a -> Validation a
Validation ((ValidationState -> [Ident])
-> ReaderT ValidationState (Either String) [Ident]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ([Ident] -> [Ident]
forall a. [a] -> [a]
List.reverse ([Ident] -> [Ident])
-> (ValidationState -> [Ident]) -> ValidationState -> [Ident]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationState -> [Ident]
validationStateCurrentContext))
  getDeclaredAttributes :: Validation (Set AttributeDecl)
getDeclaredAttributes = ReaderT ValidationState (Either String) (Set AttributeDecl)
-> Validation (Set AttributeDecl)
forall a. ReaderT ValidationState (Either String) a -> Validation a
Validation ((ValidationState -> Set AttributeDecl)
-> ReaderT ValidationState (Either String) (Set AttributeDecl)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ValidationState -> Set AttributeDecl
validationStateAllAttributes)
  throwErrorMsg :: String -> Validation a
throwErrorMsg String
msg = do
    [Ident]
idents <- Validation [Ident]
forall (m :: * -> *). MonadValidation m => m [Ident]
getContext
    if [Ident] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ident]
idents
      then ReaderT ValidationState (Either String) a -> Validation a
forall a. ReaderT ValidationState (Either String) a -> Validation a
Validation (String -> ReaderT ValidationState (Either String) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
msg)
      else ReaderT ValidationState (Either String) a -> Validation a
forall a. ReaderT ValidationState (Either String) a -> Validation a
Validation (ReaderT ValidationState (Either String) a -> Validation a)
-> (String -> ReaderT ValidationState (Either String) a)
-> String
-> Validation a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ReaderT ValidationState (Either String) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Validation a) -> String -> Validation a
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"." (Text -> String
T.unpack (Text -> String) -> (Ident -> Text) -> Ident -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
unIdent (Ident -> String) -> [Ident] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ident]
idents) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg

instance MonadValidation m => MonadValidation (StateT s m)  where
  validating :: a -> StateT s m b -> StateT s m b
validating            = (m (b, s) -> m (b, s)) -> StateT s m b -> StateT s m b
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT ((m (b, s) -> m (b, s)) -> StateT s m b -> StateT s m b)
-> (a -> m (b, s) -> m (b, s)) -> a -> StateT s m b -> StateT s m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (b, s) -> m (b, s)
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating
  resetContext :: StateT s m a -> StateT s m a
resetContext          = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT m (a, s) -> m (a, s)
forall (m :: * -> *) a. MonadValidation m => m a -> m a
resetContext
  getContext :: StateT s m [Ident]
getContext            = m [Ident] -> StateT s m [Ident]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m [Ident]
forall (m :: * -> *). MonadValidation m => m [Ident]
getContext
  getDeclaredAttributes :: StateT s m (Set AttributeDecl)
getDeclaredAttributes = m (Set AttributeDecl) -> StateT s m (Set AttributeDecl)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m (Set AttributeDecl)
forall (m :: * -> *). MonadValidation m => m (Set AttributeDecl)
getDeclaredAttributes
  throwErrorMsg :: String -> StateT s m a
throwErrorMsg         = m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a) -> (String -> m a) -> String -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg

----------------------------------
------- Validation stages --------
----------------------------------
data SymbolTable enum struct table union = SymbolTable
  { SymbolTable enum struct table union -> Map (Namespace, Ident) enum
allEnums   :: !(Map (Namespace, Ident) enum)
  , SymbolTable enum struct table union
-> Map (Namespace, Ident) struct
allStructs :: !(Map (Namespace, Ident) struct)
  , SymbolTable enum struct table union -> Map (Namespace, Ident) table
allTables  :: !(Map (Namespace, Ident) table)
  , SymbolTable enum struct table union -> Map (Namespace, Ident) union
allUnions  :: !(Map (Namespace, Ident) union)
  }
  deriving (SymbolTable enum struct table union
-> SymbolTable enum struct table union -> Bool
(SymbolTable enum struct table union
 -> SymbolTable enum struct table union -> Bool)
-> (SymbolTable enum struct table union
    -> SymbolTable enum struct table union -> Bool)
-> Eq (SymbolTable enum struct table union)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall enum struct table union.
(Eq enum, Eq struct, Eq table, Eq union) =>
SymbolTable enum struct table union
-> SymbolTable enum struct table union -> Bool
/= :: SymbolTable enum struct table union
-> SymbolTable enum struct table union -> Bool
$c/= :: forall enum struct table union.
(Eq enum, Eq struct, Eq table, Eq union) =>
SymbolTable enum struct table union
-> SymbolTable enum struct table union -> Bool
== :: SymbolTable enum struct table union
-> SymbolTable enum struct table union -> Bool
$c== :: forall enum struct table union.
(Eq enum, Eq struct, Eq table, Eq union) =>
SymbolTable enum struct table union
-> SymbolTable enum struct table union -> Bool
Eq, Int -> SymbolTable enum struct table union -> String -> String
[SymbolTable enum struct table union] -> String -> String
SymbolTable enum struct table union -> String
(Int -> SymbolTable enum struct table union -> String -> String)
-> (SymbolTable enum struct table union -> String)
-> ([SymbolTable enum struct table union] -> String -> String)
-> Show (SymbolTable enum struct table union)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
forall enum struct table union.
(Show enum, Show struct, Show table, Show union) =>
Int -> SymbolTable enum struct table union -> String -> String
forall enum struct table union.
(Show enum, Show struct, Show table, Show union) =>
[SymbolTable enum struct table union] -> String -> String
forall enum struct table union.
(Show enum, Show struct, Show table, Show union) =>
SymbolTable enum struct table union -> String
showList :: [SymbolTable enum struct table union] -> String -> String
$cshowList :: forall enum struct table union.
(Show enum, Show struct, Show table, Show union) =>
[SymbolTable enum struct table union] -> String -> String
show :: SymbolTable enum struct table union -> String
$cshow :: forall enum struct table union.
(Show enum, Show struct, Show table, Show union) =>
SymbolTable enum struct table union -> String
showsPrec :: Int -> SymbolTable enum struct table union -> String -> String
$cshowsPrec :: forall enum struct table union.
(Show enum, Show struct, Show table, Show union) =>
Int -> SymbolTable enum struct table union -> String -> String
Show)

instance Semigroup (SymbolTable e s t u)  where
  SymbolTable Map (Namespace, Ident) e
e1 Map (Namespace, Ident) s
s1 Map (Namespace, Ident) t
t1 Map (Namespace, Ident) u
u1 <> :: SymbolTable e s t u -> SymbolTable e s t u -> SymbolTable e s t u
<> SymbolTable Map (Namespace, Ident) e
e2 Map (Namespace, Ident) s
s2 Map (Namespace, Ident) t
t2 Map (Namespace, Ident) u
u2 =
    Map (Namespace, Ident) e
-> Map (Namespace, Ident) s
-> Map (Namespace, Ident) t
-> Map (Namespace, Ident) u
-> SymbolTable e s t u
forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
SymbolTable (Map (Namespace, Ident) e
e1 Map (Namespace, Ident) e
-> Map (Namespace, Ident) e -> Map (Namespace, Ident) e
forall a. Semigroup a => a -> a -> a
<> Map (Namespace, Ident) e
e2) (Map (Namespace, Ident) s
s1 Map (Namespace, Ident) s
-> Map (Namespace, Ident) s -> Map (Namespace, Ident) s
forall a. Semigroup a => a -> a -> a
<> Map (Namespace, Ident) s
s2) (Map (Namespace, Ident) t
t1 Map (Namespace, Ident) t
-> Map (Namespace, Ident) t -> Map (Namespace, Ident) t
forall a. Semigroup a => a -> a -> a
<> Map (Namespace, Ident) t
t2) (Map (Namespace, Ident) u
u1 Map (Namespace, Ident) u
-> Map (Namespace, Ident) u -> Map (Namespace, Ident) u
forall a. Semigroup a => a -> a -> a
<> Map (Namespace, Ident) u
u2)

instance Monoid (SymbolTable e s t u) where
  mempty :: SymbolTable e s t u
mempty = Map (Namespace, Ident) e
-> Map (Namespace, Ident) s
-> Map (Namespace, Ident) t
-> Map (Namespace, Ident) u
-> SymbolTable e s t u
forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
SymbolTable Map (Namespace, Ident) e
forall a. Monoid a => a
mempty Map (Namespace, Ident) s
forall a. Monoid a => a
mempty Map (Namespace, Ident) t
forall a. Monoid a => a
mempty Map (Namespace, Ident) u
forall a. Monoid a => a
mempty

{-
During validation, we translate `SyntaxTree.EnumDecl`, `SyntaxTree.StructDecl`, etc
into `ValidSyntaxTree.EnumDecl`, `ValidSyntaxTree.StructDecl`, etc.

This is done in stages: we first translate enums, then structs, then tables,
and lastly unions.
-}
type Stage1     = SymbolTable ST.EnumDecl ST.StructDecl ST.TableDecl ST.UnionDecl
type Stage2     = SymbolTable    EnumDecl ST.StructDecl ST.TableDecl ST.UnionDecl
type Stage3     = SymbolTable    EnumDecl    StructDecl ST.TableDecl ST.UnionDecl
type Stage4     = SymbolTable    EnumDecl    StructDecl    TableDecl ST.UnionDecl
type ValidDecls = SymbolTable    EnumDecl    StructDecl    TableDecl    UnionDecl

validateSchemas :: FileTree Schema -> Either String (FileTree ValidDecls)
validateSchemas :: FileTree Schema -> Either String (FileTree ValidDecls)
validateSchemas FileTree Schema
schemas =
  (ReaderT ValidationState (Either String) (FileTree ValidDecls)
 -> ValidationState -> Either String (FileTree ValidDecls))
-> ValidationState
-> ReaderT ValidationState (Either String) (FileTree ValidDecls)
-> Either String (FileTree ValidDecls)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT ValidationState (Either String) (FileTree ValidDecls)
-> ValidationState -> Either String (FileTree ValidDecls)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([Ident] -> Set AttributeDecl -> ValidationState
ValidationState [] Set AttributeDecl
allAttributes) (ReaderT ValidationState (Either String) (FileTree ValidDecls)
 -> Either String (FileTree ValidDecls))
-> ReaderT ValidationState (Either String) (FileTree ValidDecls)
-> Either String (FileTree ValidDecls)
forall a b. (a -> b) -> a -> b
$ Validation (FileTree ValidDecls)
-> ReaderT ValidationState (Either String) (FileTree ValidDecls)
forall a. Validation a -> ReaderT ValidationState (Either String) a
runValidation (Validation (FileTree ValidDecls)
 -> ReaderT ValidationState (Either String) (FileTree ValidDecls))
-> Validation (FileTree ValidDecls)
-> ReaderT ValidationState (Either String) (FileTree ValidDecls)
forall a b. (a -> b) -> a -> b
$ do
    FileTree Stage1
symbolTables <- FileTree Schema -> Validation (FileTree Stage1)
createSymbolTables FileTree Schema
schemas
    [Ident] -> Validation ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadValidation m, Foldable f, Functor f, HasIdent a) =>
f a -> m ()
checkDuplicateIdentifiers (FileTree Stage1 -> [Ident]
forall (t :: * -> *) enum struct table a.
Foldable t =>
t (SymbolTable enum struct table a) -> [Ident]
allQualifiedTopLevelIdentifiers FileTree Stage1
symbolTables)
    FileTree Stage1 -> Validation (FileTree Stage2)
validateEnums FileTree Stage1
symbolTables
      Validation (FileTree Stage2)
-> (FileTree Stage2 -> Validation (FileTree Stage3))
-> Validation (FileTree Stage3)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FileTree Stage2 -> Validation (FileTree Stage3)
validateStructs
      Validation (FileTree Stage3)
-> (FileTree Stage3 -> Validation (FileTree Stage4))
-> Validation (FileTree Stage4)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FileTree Stage3 -> Validation (FileTree Stage4)
validateTables
      Validation (FileTree Stage4)
-> (FileTree Stage4 -> Validation (FileTree ValidDecls))
-> Validation (FileTree ValidDecls)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FileTree Stage4 -> Validation (FileTree ValidDecls)
validateUnions
      Validation (FileTree ValidDecls)
-> (FileTree ValidDecls -> Validation (FileTree ValidDecls))
-> Validation (FileTree ValidDecls)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Schema -> FileTree ValidDecls -> Validation (FileTree ValidDecls)
updateRootTable (FileTree Schema -> Schema
forall a. FileTree a -> a
fileTreeRoot FileTree Schema
schemas)
  where
    allQualifiedTopLevelIdentifiers :: t (SymbolTable enum struct table a) -> [Ident]
allQualifiedTopLevelIdentifiers t (SymbolTable enum struct table a)
symbolTables =
      ((SymbolTable enum struct table a -> [Ident])
 -> t (SymbolTable enum struct table a) -> [Ident])
-> t (SymbolTable enum struct table a)
-> (SymbolTable enum struct table a -> [Ident])
-> [Ident]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SymbolTable enum struct table a -> [Ident])
-> t (SymbolTable enum struct table a) -> [Ident]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap t (SymbolTable enum struct table a)
symbolTables ((SymbolTable enum struct table a -> [Ident]) -> [Ident])
-> (SymbolTable enum struct table a -> [Ident]) -> [Ident]
forall a b. (a -> b) -> a -> b
$ \SymbolTable enum struct table a
symbolTable ->
        [[Ident]] -> [Ident]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
          [ (Namespace -> Ident -> Ident) -> (Namespace, Ident) -> Ident
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Namespace -> Ident -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify ((Namespace, Ident) -> Ident) -> [(Namespace, Ident)] -> [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Namespace, Ident) enum -> [(Namespace, Ident)]
forall k a. Map k a -> [k]
Map.keys (SymbolTable enum struct table a -> Map (Namespace, Ident) enum
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) enum
allEnums SymbolTable enum struct table a
symbolTable)
          , (Namespace -> Ident -> Ident) -> (Namespace, Ident) -> Ident
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Namespace -> Ident -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify ((Namespace, Ident) -> Ident) -> [(Namespace, Ident)] -> [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Namespace, Ident) struct -> [(Namespace, Ident)]
forall k a. Map k a -> [k]
Map.keys (SymbolTable enum struct table a -> Map (Namespace, Ident) struct
forall enum struct table union.
SymbolTable enum struct table union
-> Map (Namespace, Ident) struct
allStructs SymbolTable enum struct table a
symbolTable)
          , (Namespace -> Ident -> Ident) -> (Namespace, Ident) -> Ident
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Namespace -> Ident -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify ((Namespace, Ident) -> Ident) -> [(Namespace, Ident)] -> [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Namespace, Ident) table -> [(Namespace, Ident)]
forall k a. Map k a -> [k]
Map.keys (SymbolTable enum struct table a -> Map (Namespace, Ident) table
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) table
allTables SymbolTable enum struct table a
symbolTable)
          , (Namespace -> Ident -> Ident) -> (Namespace, Ident) -> Ident
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Namespace -> Ident -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify ((Namespace, Ident) -> Ident) -> [(Namespace, Ident)] -> [Ident]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (Namespace, Ident) a -> [(Namespace, Ident)]
forall k a. Map k a -> [k]
Map.keys (SymbolTable enum struct table a -> Map (Namespace, Ident) a
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) union
allUnions SymbolTable enum struct table a
symbolTable)
          ]

    declaredAttributes :: [AttributeDecl]
declaredAttributes =
      ((Schema -> [AttributeDecl]) -> FileTree Schema -> [AttributeDecl])
-> FileTree Schema
-> (Schema -> [AttributeDecl])
-> [AttributeDecl]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Schema -> [AttributeDecl]) -> FileTree Schema -> [AttributeDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FileTree Schema
schemas ((Schema -> [AttributeDecl]) -> [AttributeDecl])
-> (Schema -> [AttributeDecl]) -> [AttributeDecl]
forall a b. (a -> b) -> a -> b
$ \Schema
schema ->
        [ AttributeDecl
attr | ST.DeclA AttributeDecl
attr <- Schema -> [Decl]
ST.decls Schema
schema ]

    allAttributes :: Set AttributeDecl
allAttributes = [AttributeDecl] -> Set AttributeDecl
forall a. Ord a => [a] -> Set a
Set.fromList ([AttributeDecl] -> Set AttributeDecl)
-> [AttributeDecl] -> Set AttributeDecl
forall a b. (a -> b) -> a -> b
$ [AttributeDecl]
declaredAttributes [AttributeDecl] -> [AttributeDecl] -> [AttributeDecl]
forall a. Semigroup a => a -> a -> a
<> [AttributeDecl]
knownAttributes

-- | Takes a collection of schemas, and pairs each type declaration with its corresponding namespace
createSymbolTables :: FileTree Schema -> Validation (FileTree Stage1)
createSymbolTables :: FileTree Schema -> Validation (FileTree Stage1)
createSymbolTables = (Schema -> Validation Stage1)
-> FileTree Schema -> Validation (FileTree Stage1)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Decl] -> Validation Stage1
createSymbolTable ([Decl] -> Validation Stage1)
-> (Schema -> [Decl]) -> Schema -> Validation Stage1
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> [Decl]
ST.decls)
  where
    createSymbolTable :: [ST.Decl] -> Validation Stage1
    createSymbolTable :: [Decl] -> Validation Stage1
createSymbolTable [Decl]
decls = (Namespace, Stage1) -> Stage1
forall a b. (a, b) -> b
snd ((Namespace, Stage1) -> Stage1)
-> Validation (Namespace, Stage1) -> Validation Stage1
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Namespace, Stage1) -> Decl -> Validation (Namespace, Stage1))
-> (Namespace, Stage1) -> [Decl] -> Validation (Namespace, Stage1)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Namespace, Stage1) -> Decl -> Validation (Namespace, Stage1)
go (Namespace
"", Stage1
forall a. Monoid a => a
mempty) [Decl]
decls

    go :: (Namespace, Stage1) -> ST.Decl -> Validation (Namespace, Stage1)
    go :: (Namespace, Stage1) -> Decl -> Validation (Namespace, Stage1)
go (Namespace
currentNamespace, Stage1
symbolTable) Decl
decl =
      case Decl
decl of
        ST.DeclE EnumDecl
enum   -> Stage1 -> Namespace -> EnumDecl -> Validation Stage1
forall enum struct table union.
HasIdent enum =>
SymbolTable enum struct table union
-> Namespace
-> enum
-> Validation (SymbolTable enum struct table union)
addEnum Stage1
symbolTable Namespace
currentNamespace EnumDecl
enum     Validation Stage1
-> (Stage1 -> (Namespace, Stage1))
-> Validation (Namespace, Stage1)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Stage1
symbolTable' -> (Namespace
currentNamespace, Stage1
symbolTable')
        ST.DeclS StructDecl
struct -> Stage1 -> Namespace -> StructDecl -> Validation Stage1
forall struct enum table union.
HasIdent struct =>
SymbolTable enum struct table union
-> Namespace
-> struct
-> Validation (SymbolTable enum struct table union)
addStruct Stage1
symbolTable Namespace
currentNamespace StructDecl
struct Validation Stage1
-> (Stage1 -> (Namespace, Stage1))
-> Validation (Namespace, Stage1)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Stage1
symbolTable' -> (Namespace
currentNamespace, Stage1
symbolTable')
        ST.DeclT TableDecl
table  -> Stage1 -> Namespace -> TableDecl -> Validation Stage1
forall table enum struct union.
HasIdent table =>
SymbolTable enum struct table union
-> Namespace
-> table
-> Validation (SymbolTable enum struct table union)
addTable Stage1
symbolTable Namespace
currentNamespace TableDecl
table   Validation Stage1
-> (Stage1 -> (Namespace, Stage1))
-> Validation (Namespace, Stage1)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Stage1
symbolTable' -> (Namespace
currentNamespace, Stage1
symbolTable')
        ST.DeclU UnionDecl
union  -> Stage1 -> Namespace -> UnionDecl -> Validation Stage1
forall union enum struct table.
HasIdent union =>
SymbolTable enum struct table union
-> Namespace
-> union
-> Validation (SymbolTable enum struct table union)
addUnion Stage1
symbolTable Namespace
currentNamespace UnionDecl
union   Validation Stage1
-> (Stage1 -> (Namespace, Stage1))
-> Validation (Namespace, Stage1)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Stage1
symbolTable' -> (Namespace
currentNamespace, Stage1
symbolTable')
        ST.DeclN (ST.NamespaceDecl Namespace
newNamespace) -> (Namespace, Stage1) -> Validation (Namespace, Stage1)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
newNamespace, Stage1
symbolTable)
        Decl
_               -> (Namespace, Stage1) -> Validation (Namespace, Stage1)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
currentNamespace, Stage1
symbolTable)

    addEnum :: SymbolTable enum struct table union
-> Namespace
-> enum
-> Validation (SymbolTable enum struct table union)
addEnum (SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us) Namespace
namespace enum
enum     = Namespace
-> enum
-> Map (Namespace, Ident) enum
-> Validation (Map (Namespace, Ident) enum)
forall a.
HasIdent a =>
Namespace
-> a
-> Map (Namespace, Ident) a
-> Validation (Map (Namespace, Ident) a)
insertSymbol Namespace
namespace enum
enum Map (Namespace, Ident) enum
es   Validation (Map (Namespace, Ident) enum)
-> (Map (Namespace, Ident) enum
    -> SymbolTable enum struct table union)
-> Validation (SymbolTable enum struct table union)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map (Namespace, Ident) enum
es' -> Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
SymbolTable Map (Namespace, Ident) enum
es' Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us
    addStruct :: SymbolTable enum struct table union
-> Namespace
-> struct
-> Validation (SymbolTable enum struct table union)
addStruct (SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us) Namespace
namespace struct
struct = Namespace
-> struct
-> Map (Namespace, Ident) struct
-> Validation (Map (Namespace, Ident) struct)
forall a.
HasIdent a =>
Namespace
-> a
-> Map (Namespace, Ident) a
-> Validation (Map (Namespace, Ident) a)
insertSymbol Namespace
namespace struct
struct Map (Namespace, Ident) struct
ss Validation (Map (Namespace, Ident) struct)
-> (Map (Namespace, Ident) struct
    -> SymbolTable enum struct table union)
-> Validation (SymbolTable enum struct table union)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map (Namespace, Ident) struct
ss' -> Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss' Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us
    addTable :: SymbolTable enum struct table union
-> Namespace
-> table
-> Validation (SymbolTable enum struct table union)
addTable (SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us) Namespace
namespace table
table   = Namespace
-> table
-> Map (Namespace, Ident) table
-> Validation (Map (Namespace, Ident) table)
forall a.
HasIdent a =>
Namespace
-> a
-> Map (Namespace, Ident) a
-> Validation (Map (Namespace, Ident) a)
insertSymbol Namespace
namespace table
table Map (Namespace, Ident) table
ts  Validation (Map (Namespace, Ident) table)
-> (Map (Namespace, Ident) table
    -> SymbolTable enum struct table union)
-> Validation (SymbolTable enum struct table union)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map (Namespace, Ident) table
ts' -> Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts' Map (Namespace, Ident) union
us
    addUnion :: SymbolTable enum struct table union
-> Namespace
-> union
-> Validation (SymbolTable enum struct table union)
addUnion (SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us) Namespace
namespace union
union   = Namespace
-> union
-> Map (Namespace, Ident) union
-> Validation (Map (Namespace, Ident) union)
forall a.
HasIdent a =>
Namespace
-> a
-> Map (Namespace, Ident) a
-> Validation (Map (Namespace, Ident) a)
insertSymbol Namespace
namespace union
union Map (Namespace, Ident) union
us  Validation (Map (Namespace, Ident) union)
-> (Map (Namespace, Ident) union
    -> SymbolTable enum struct table union)
-> Validation (SymbolTable enum struct table union)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Map (Namespace, Ident) union
us' -> Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
forall enum struct table union.
Map (Namespace, Ident) enum
-> Map (Namespace, Ident) struct
-> Map (Namespace, Ident) table
-> Map (Namespace, Ident) union
-> SymbolTable enum struct table union
SymbolTable Map (Namespace, Ident) enum
es Map (Namespace, Ident) struct
ss Map (Namespace, Ident) table
ts Map (Namespace, Ident) union
us'

-- | Fails if the key is already present in the map.
insertSymbol :: HasIdent a => Namespace -> a -> Map (Namespace, Ident) a -> Validation (Map (Namespace, Ident) a)
insertSymbol :: Namespace
-> a
-> Map (Namespace, Ident) a
-> Validation (Map (Namespace, Ident) a)
insertSymbol Namespace
namespace a
symbol Map (Namespace, Ident) a
map =
  if (Namespace, Ident) -> Map (Namespace, Ident) a -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Namespace, Ident)
key Map (Namespace, Ident) a
map
    then String -> Validation (Map (Namespace, Ident) a)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation (Map (Namespace, Ident) a))
-> String -> Validation (Map (Namespace, Ident) a)
forall a b. (a -> b) -> a -> b
$ Ident -> String
forall a. Display a => a -> String
display (Namespace -> a -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify Namespace
namespace a
symbol) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" declared more than once"
    else Map (Namespace, Ident) a -> Validation (Map (Namespace, Ident) a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map (Namespace, Ident) a -> Validation (Map (Namespace, Ident) a))
-> Map (Namespace, Ident) a
-> Validation (Map (Namespace, Ident) a)
forall a b. (a -> b) -> a -> b
$ (Namespace, Ident)
-> a -> Map (Namespace, Ident) a -> Map (Namespace, Ident) a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Namespace, Ident)
key a
symbol Map (Namespace, Ident) a
map
  where
    key :: (Namespace, Ident)
key = (Namespace
namespace, a -> Ident
forall a. HasIdent a => a -> Ident
getIdent a
symbol)


----------------------------------
------------ Root Type -----------
----------------------------------

-- | Finds the root table (if any) and sets the `tableIsRoot` flag accordingly.
-- We only care about @root_type@ declarations in the root schema. Imported schemas are not scanned for @root_type@s.
-- The root type declaration can point to a table in any schema (root or imported).
updateRootTable :: Schema -> FileTree ValidDecls -> Validation (FileTree ValidDecls)
updateRootTable :: Schema -> FileTree ValidDecls -> Validation (FileTree ValidDecls)
updateRootTable Schema
schema FileTree ValidDecls
symbolTables =
  Schema -> FileTree ValidDecls -> Validation (Maybe RootInfo)
getRootInfo Schema
schema FileTree ValidDecls
symbolTables Validation (Maybe RootInfo)
-> (Maybe RootInfo -> FileTree ValidDecls)
-> Validation (FileTree ValidDecls)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Just RootInfo
rootInfo -> RootInfo -> ValidDecls -> ValidDecls
updateSymbolTable RootInfo
rootInfo (ValidDecls -> ValidDecls)
-> FileTree ValidDecls -> FileTree ValidDecls
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FileTree ValidDecls
symbolTables
    Maybe RootInfo
Nothing       -> FileTree ValidDecls
symbolTables

  where
    updateSymbolTable :: RootInfo -> ValidDecls -> ValidDecls
    updateSymbolTable :: RootInfo -> ValidDecls -> ValidDecls
updateSymbolTable RootInfo
rootInfo ValidDecls
st = ValidDecls
st { allTables :: Map (Namespace, Ident) TableDecl
allTables = ((Namespace, Ident) -> TableDecl -> TableDecl)
-> Map (Namespace, Ident) TableDecl
-> Map (Namespace, Ident) TableDecl
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (RootInfo -> (Namespace, Ident) -> TableDecl -> TableDecl
updateTable RootInfo
rootInfo) (ValidDecls -> Map (Namespace, Ident) TableDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) table
allTables ValidDecls
st) }

    updateTable :: RootInfo -> (Namespace, Ident) -> TableDecl -> TableDecl
    updateTable :: RootInfo -> (Namespace, Ident) -> TableDecl -> TableDecl
updateTable (RootInfo Namespace
rootTableNamespace TableDecl
rootTable Maybe Text
fileIdent) (Namespace
namespace, Ident
_) TableDecl
table =
      if Namespace
namespace Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Namespace
rootTableNamespace Bool -> Bool -> Bool
&& TableDecl
table TableDecl -> TableDecl -> Bool
forall a. Eq a => a -> a -> Bool
== TableDecl
rootTable
        then TableDecl
table { tableIsRoot :: IsRoot
tableIsRoot = Maybe Text -> IsRoot
IsRoot Maybe Text
fileIdent }
        else TableDecl
table

data RootInfo = RootInfo
  { RootInfo -> Namespace
rootTableNamespace :: !Namespace
  , RootInfo -> TableDecl
rootTable          :: !TableDecl
  , RootInfo -> Maybe Text
rootFileIdent      :: !(Maybe Text)
  }

-- | Finds the @root_type@ declaration (if any), and what table it's pointing to.
getRootInfo :: Schema -> FileTree ValidDecls -> Validation (Maybe RootInfo)
getRootInfo :: Schema -> FileTree ValidDecls -> Validation (Maybe RootInfo)
getRootInfo Schema
schema FileTree ValidDecls
symbolTables =
  ((Namespace, Maybe (Namespace, TableDecl), Maybe Text)
 -> Decl
 -> Validation
      (Namespace, Maybe (Namespace, TableDecl), Maybe Text))
-> (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> [Decl]
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> Decl
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
go (Namespace
"", Maybe (Namespace, TableDecl)
forall a. Maybe a
Nothing, Maybe Text
forall a. Maybe a
Nothing) (Schema -> [Decl]
ST.decls Schema
schema) Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> ((Namespace, Maybe (Namespace, TableDecl), Maybe Text)
    -> Maybe RootInfo)
-> Validation (Maybe RootInfo)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (Namespace
_, Just (Namespace
rootTableNamespace, TableDecl
rootTable), Maybe Text
fileIdent) -> RootInfo -> Maybe RootInfo
forall a. a -> Maybe a
Just (RootInfo -> Maybe RootInfo) -> RootInfo -> Maybe RootInfo
forall a b. (a -> b) -> a -> b
$ Namespace -> TableDecl -> Maybe Text -> RootInfo
RootInfo Namespace
rootTableNamespace TableDecl
rootTable Maybe Text
fileIdent
    (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
_ -> Maybe RootInfo
forall a. Maybe a
Nothing
  where
    go :: (Namespace, Maybe (Namespace, TableDecl), Maybe Text) -> ST.Decl -> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
    go :: (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> Decl
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
go state :: (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
state@(Namespace
currentNamespace, Maybe (Namespace, TableDecl)
rootInfo, Maybe Text
fileIdent) Decl
decl =
      case Decl
decl of
        ST.DeclN (ST.NamespaceDecl Namespace
newNamespace)       -> (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
newNamespace, Maybe (Namespace, TableDecl)
rootInfo, Maybe Text
fileIdent)
        ST.DeclFI (ST.FileIdentifierDecl Text
newFileIdent) -> (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
currentNamespace, Maybe (Namespace, TableDecl)
rootInfo, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Text
coerce Text
newFileIdent))
        ST.DeclR (ST.RootDecl TypeRef
typeRef)                 ->
          Namespace
-> FileTree ValidDecls
-> TypeRef
-> Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
forall (m :: * -> *) e s t u.
MonadValidation m =>
Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree ValidDecls
symbolTables TypeRef
typeRef Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
-> (Match EnumDecl StructDecl TableDecl UnionDecl
    -> Validation
         (Namespace, Maybe (Namespace, TableDecl), Maybe Text))
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            MatchT Namespace
rootTableNamespace TableDecl
rootTable  -> (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
currentNamespace, (Namespace, TableDecl) -> Maybe (Namespace, TableDecl)
forall a. a -> Maybe a
Just (Namespace
rootTableNamespace, TableDecl
rootTable), Maybe Text
fileIdent)
            Match EnumDecl StructDecl TableDecl UnionDecl
_                                    -> String
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"root type must be a table"
        Decl
_ -> (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
-> Validation (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace, Maybe (Namespace, TableDecl), Maybe Text)
state

----------------------------------
----------- Attributes -----------
----------------------------------
knownAttributes :: [ST.AttributeDecl]
knownAttributes :: [AttributeDecl]
knownAttributes =
  [Text] -> [AttributeDecl]
coerce
    [ Text
idAttr
    , Text
deprecatedAttr
    , Text
requiredAttr
    , Text
forceAlignAttr
    , Text
bitFlagsAttr
    ]
  [AttributeDecl] -> [AttributeDecl] -> [AttributeDecl]
forall a. Semigroup a => a -> a -> a
<> [AttributeDecl]
otherKnownAttributes

idAttr, deprecatedAttr, requiredAttr, forceAlignAttr, bitFlagsAttr :: Text
idAttr :: Text
idAttr          = Text
"id"
deprecatedAttr :: Text
deprecatedAttr  = Text
"deprecated"
requiredAttr :: Text
requiredAttr    = Text
"required"
forceAlignAttr :: Text
forceAlignAttr  = Text
"force_align"
bitFlagsAttr :: Text
bitFlagsAttr    = Text
"bit_flags"

otherKnownAttributes :: [ST.AttributeDecl]
otherKnownAttributes :: [AttributeDecl]
otherKnownAttributes =
  -- https://google.github.io/flatbuffers/flatbuffers_guide_writing_schema.html
  [ AttributeDecl
"nested_flatbuffer"
  , AttributeDecl
"flexbuffer"
  , AttributeDecl
"key"
  , AttributeDecl
"hash"
  , AttributeDecl
"original_order"
  -- https://google.github.io/flatbuffers/flatbuffers_guide_use_cpp.html#flatbuffers_cpp_object_based_api
  , AttributeDecl
"native_inline"
  , AttributeDecl
"native_default"
  , AttributeDecl
"native_custom_alloc"
  , AttributeDecl
"native_type"
  , AttributeDecl
"cpp_type"
  , AttributeDecl
"cpp_ptr_type"
  , AttributeDecl
"cpp_str_type"
  , AttributeDecl
"cpp_str_flex_ctor"
  , AttributeDecl
"shared"
  ]

----------------------------------
--------- Symbol search ----------
----------------------------------
data Match enum struct table union
  = MatchE !Namespace !enum
  | MatchS !Namespace !struct
  | MatchT !Namespace !table
  | MatchU !Namespace !union

-- | Looks for a type reference in a set of type declarations.
findDecl ::
     MonadValidation m
  => Namespace
  -> FileTree (SymbolTable e s t u)
  -> TypeRef
  -> m (Match e s t u)
findDecl :: Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree (SymbolTable e s t u)
symbolTables typeRef :: TypeRef
typeRef@(TypeRef Namespace
refNamespace Ident
refIdent) =
  let parentNamespaces' :: NonEmpty Namespace
parentNamespaces' = Namespace -> NonEmpty Namespace
parentNamespaces Namespace
currentNamespace
      results :: NonEmpty (Maybe (Match e s t u))
results = do
        Namespace
parentNamespace <- NonEmpty Namespace
parentNamespaces'
        let candidateNamespace :: Namespace
candidateNamespace = Namespace
parentNamespace Namespace -> Namespace -> Namespace
forall a. Semigroup a => a -> a -> a
<> Namespace
refNamespace
        let searchSymbolTable :: SymbolTable enum struct table union
-> Maybe (Match enum struct table union)
searchSymbolTable SymbolTable enum struct table union
symbolTable =
              [Maybe (Match enum struct table union)]
-> Maybe (Match enum struct table union)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
                [ Namespace -> enum -> Match enum struct table union
forall enum struct table union.
Namespace -> enum -> Match enum struct table union
MatchE Namespace
candidateNamespace (enum -> Match enum struct table union)
-> Maybe enum -> Maybe (Match enum struct table union)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Namespace, Ident) -> Map (Namespace, Ident) enum -> Maybe enum
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace
candidateNamespace, Ident
refIdent) (SymbolTable enum struct table union -> Map (Namespace, Ident) enum
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) enum
allEnums SymbolTable enum struct table union
symbolTable)
                , Namespace -> struct -> Match enum struct table union
forall enum struct table union.
Namespace -> struct -> Match enum struct table union
MatchS Namespace
candidateNamespace (struct -> Match enum struct table union)
-> Maybe struct -> Maybe (Match enum struct table union)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Namespace, Ident) -> Map (Namespace, Ident) struct -> Maybe struct
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace
candidateNamespace, Ident
refIdent) (SymbolTable enum struct table union
-> Map (Namespace, Ident) struct
forall enum struct table union.
SymbolTable enum struct table union
-> Map (Namespace, Ident) struct
allStructs SymbolTable enum struct table union
symbolTable)
                , Namespace -> table -> Match enum struct table union
forall enum struct table union.
Namespace -> table -> Match enum struct table union
MatchT Namespace
candidateNamespace (table -> Match enum struct table union)
-> Maybe table -> Maybe (Match enum struct table union)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Namespace, Ident) -> Map (Namespace, Ident) table -> Maybe table
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace
candidateNamespace, Ident
refIdent) (SymbolTable enum struct table union -> Map (Namespace, Ident) table
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) table
allTables SymbolTable enum struct table union
symbolTable)
                , Namespace -> union -> Match enum struct table union
forall enum struct table union.
Namespace -> union -> Match enum struct table union
MatchU Namespace
candidateNamespace (union -> Match enum struct table union)
-> Maybe union -> Maybe (Match enum struct table union)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Namespace, Ident) -> Map (Namespace, Ident) union -> Maybe union
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace
candidateNamespace, Ident
refIdent) (SymbolTable enum struct table union -> Map (Namespace, Ident) union
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) union
allUnions SymbolTable enum struct table union
symbolTable)
                ]
        Maybe (Match e s t u) -> NonEmpty (Maybe (Match e s t u))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Match e s t u) -> NonEmpty (Maybe (Match e s t u)))
-> Maybe (Match e s t u) -> NonEmpty (Maybe (Match e s t u))
forall a b. (a -> b) -> a -> b
$ FileTree (Maybe (Match e s t u)) -> Maybe (Match e s t u)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (FileTree (Maybe (Match e s t u)) -> Maybe (Match e s t u))
-> FileTree (Maybe (Match e s t u)) -> Maybe (Match e s t u)
forall a b. (a -> b) -> a -> b
$ (SymbolTable e s t u -> Maybe (Match e s t u))
-> FileTree (SymbolTable e s t u)
-> FileTree (Maybe (Match e s t u))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SymbolTable e s t u -> Maybe (Match e s t u)
forall enum struct table union.
SymbolTable enum struct table union
-> Maybe (Match enum struct table union)
searchSymbolTable FileTree (SymbolTable e s t u)
symbolTables
  in
    case NonEmpty (Maybe (Match e s t u)) -> Maybe (Match e s t u)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum NonEmpty (Maybe (Match e s t u))
results of
      Just Match e s t u
match -> Match e s t u -> m (Match e s t u)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Match e s t u
match
      Maybe (Match e s t u)
Nothing    ->
        String -> m (Match e s t u)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> m (Match e s t u)) -> String -> m (Match e s t u)
forall a b. (a -> b) -> a -> b
$
          String
"type "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRef -> String
forall a. Display a => a -> String
display TypeRef
typeRef
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not exist (checked in these namespaces: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Namespace -> String
forall a. Display a => a -> String
display NonEmpty Namespace
parentNamespaces'
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | Returns a list of all the namespaces "between" the current namespace
-- and the root namespace, in that order.
-- See: https://github.com/google/flatbuffers/issues/5234#issuecomment-471680403
--
-- > parentNamespaces "A.B.C" == ["A.B.C", "A.B", "A", ""]
parentNamespaces :: ST.Namespace -> NonEmpty ST.Namespace
parentNamespaces :: Namespace -> NonEmpty Namespace
parentNamespaces (ST.Namespace [Text]
ns) =
  NonEmpty [Text] -> NonEmpty Namespace
coerce (NonEmpty [Text] -> NonEmpty Namespace)
-> NonEmpty [Text] -> NonEmpty Namespace
forall a b. (a -> b) -> a -> b
$ NonEmpty [Text] -> NonEmpty [Text]
forall a. NonEmpty a -> NonEmpty a
NE.reverse (NonEmpty [Text] -> NonEmpty [Text])
-> NonEmpty [Text] -> NonEmpty [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> NonEmpty [Text]
forall (f :: * -> *) a. Foldable f => f a -> NonEmpty [a]
NE.inits [Text]
ns

----------------------------------
------------- Enums --------------
----------------------------------
validateEnums :: FileTree Stage1 -> Validation (FileTree Stage2)
validateEnums :: FileTree Stage1 -> Validation (FileTree Stage2)
validateEnums FileTree Stage1
symbolTables =
  FileTree Stage1
-> (Stage1 -> Validation Stage2) -> Validation (FileTree Stage2)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FileTree Stage1
symbolTables ((Stage1 -> Validation Stage2) -> Validation (FileTree Stage2))
-> (Stage1 -> Validation Stage2) -> Validation (FileTree Stage2)
forall a b. (a -> b) -> a -> b
$ \Stage1
symbolTable -> do
    Map (Namespace, Ident) EnumDecl
validEnums <- ((Namespace, Ident) -> EnumDecl -> Validation EnumDecl)
-> Map (Namespace, Ident) EnumDecl
-> Validation (Map (Namespace, Ident) EnumDecl)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (Namespace, Ident) -> EnumDecl -> Validation EnumDecl
validateEnum (Stage1 -> Map (Namespace, Ident) EnumDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) enum
allEnums Stage1
symbolTable)
    Stage2 -> Validation Stage2
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stage1
symbolTable { allEnums :: Map (Namespace, Ident) EnumDecl
allEnums = Map (Namespace, Ident) EnumDecl
validEnums }

validateEnum :: (Namespace, Ident) -> ST.EnumDecl -> Validation EnumDecl
validateEnum :: (Namespace, Ident) -> EnumDecl -> Validation EnumDecl
validateEnum (Namespace
currentNamespace, Ident
_) EnumDecl
enum =
  Ident -> Validation EnumDecl -> Validation EnumDecl
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating (Namespace -> EnumDecl -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify Namespace
currentNamespace EnumDecl
enum) (Validation EnumDecl -> Validation EnumDecl)
-> Validation EnumDecl -> Validation EnumDecl
forall a b. (a -> b) -> a -> b
$ do
    Validation ()
checkDuplicateFields
    EnumDecl -> Validation ()
forall (m :: * -> *) a.
(MonadValidation m, HasMetadata a) =>
a -> m ()
checkUndeclaredAttributes EnumDecl
enum
    Validation EnumDecl
validEnum
  where
    isBitFlags :: Bool
isBitFlags = Text -> Metadata -> Bool
hasAttribute Text
bitFlagsAttr (EnumDecl -> Metadata
ST.enumMetadata EnumDecl
enum)

    validEnum :: Validation EnumDecl
validEnum = do
      EnumType
enumType <- Type -> Validation EnumType
validateEnumType (EnumDecl -> Type
ST.enumType EnumDecl
enum)
      let enumVals :: NonEmpty EnumVal
enumVals = (State (Maybe Integer) (NonEmpty EnumVal)
 -> Maybe Integer -> NonEmpty EnumVal)
-> Maybe Integer
-> State (Maybe Integer) (NonEmpty EnumVal)
-> NonEmpty EnumVal
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Maybe Integer) (NonEmpty EnumVal)
-> Maybe Integer -> NonEmpty EnumVal
forall s a. State s a -> s -> a
evalState Maybe Integer
forall a. Maybe a
Nothing (State (Maybe Integer) (NonEmpty EnumVal) -> NonEmpty EnumVal)
-> (NonEmpty EnumVal -> State (Maybe Integer) (NonEmpty EnumVal))
-> NonEmpty EnumVal
-> NonEmpty EnumVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EnumVal -> StateT (Maybe Integer) Identity EnumVal)
-> NonEmpty EnumVal -> State (Maybe Integer) (NonEmpty EnumVal)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse EnumVal -> StateT (Maybe Integer) Identity EnumVal
mapEnumVal (NonEmpty EnumVal -> NonEmpty EnumVal)
-> NonEmpty EnumVal -> NonEmpty EnumVal
forall a b. (a -> b) -> a -> b
$ EnumDecl -> NonEmpty EnumVal
ST.enumVals EnumDecl
enum
      NonEmpty EnumVal -> Validation ()
validateOrder NonEmpty EnumVal
enumVals
      (EnumVal -> Validation ()) -> NonEmpty EnumVal -> Validation ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (EnumType -> EnumVal -> Validation ()
validateBounds EnumType
enumType) NonEmpty EnumVal
enumVals
      EnumDecl -> Validation EnumDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumDecl :: Ident -> EnumType -> Bool -> NonEmpty EnumVal -> EnumDecl
EnumDecl
        { enumIdent :: Ident
enumIdent = EnumDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumDecl
enum
        , enumType :: EnumType
enumType = EnumType
enumType
        , enumBitFlags :: Bool
enumBitFlags = Bool
isBitFlags
        , enumVals :: NonEmpty EnumVal
enumVals = EnumVal -> EnumVal
shiftBitFlags (EnumVal -> EnumVal) -> NonEmpty EnumVal -> NonEmpty EnumVal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty EnumVal
enumVals
        }

    mapEnumVal :: ST.EnumVal -> State (Maybe Integer) EnumVal
    mapEnumVal :: EnumVal -> StateT (Maybe Integer) Identity EnumVal
mapEnumVal EnumVal
enumVal = do
      Integer
thisInt <-
        case EnumVal -> Maybe IntLiteral
ST.enumValLiteral EnumVal
enumVal of
          Just (ST.IntLiteral Integer
thisInt) ->
            Integer -> StateT (Maybe Integer) Identity Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
thisInt
          Maybe IntLiteral
Nothing ->
            StateT (Maybe Integer) Identity (Maybe Integer)
forall s (m :: * -> *). MonadState s m => m s
get StateT (Maybe Integer) Identity (Maybe Integer)
-> (Maybe Integer -> Integer)
-> StateT (Maybe Integer) Identity Integer
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
              Just Integer
lastInt -> Integer
lastInt Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
              Maybe Integer
Nothing      -> Integer
0
      Maybe Integer -> StateT (Maybe Integer) Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
thisInt)
      EnumVal -> StateT (Maybe Integer) Identity EnumVal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ident -> Integer -> EnumVal
EnumVal (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumVal
enumVal) Integer
thisInt)

    validateOrder :: NonEmpty EnumVal -> Validation ()
    validateOrder :: NonEmpty EnumVal -> Validation ()
validateOrder NonEmpty EnumVal
xs =
      let consecutivePairs :: [(EnumVal, EnumVal)]
consecutivePairs = NonEmpty EnumVal -> [EnumVal]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty EnumVal
xs [EnumVal] -> [EnumVal] -> [(EnumVal, EnumVal)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` NonEmpty EnumVal -> [EnumVal]
forall a. NonEmpty a -> [a]
NE.tail NonEmpty EnumVal
xs
          outOfOrderPais :: [(EnumVal, EnumVal)]
outOfOrderPais = ((EnumVal, EnumVal) -> Bool)
-> [(EnumVal, EnumVal)] -> [(EnumVal, EnumVal)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(EnumVal
x, EnumVal
y) -> EnumVal -> Integer
enumValInt EnumVal
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= EnumVal -> Integer
enumValInt EnumVal
y) [(EnumVal, EnumVal)]
consecutivePairs
      in
          case [(EnumVal, EnumVal)]
outOfOrderPais of
            []         -> () -> Validation ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            (EnumVal
x, EnumVal
y) : [(EnumVal, EnumVal)]
_ -> String -> Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation ()) -> String -> Validation ()
forall a b. (a -> b) -> a -> b
$
              String
"enum values must be specified in ascending order. "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ident -> String
forall a. Display a => a -> String
display (EnumVal -> Ident
enumValIdent EnumVal
y)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display (EnumVal -> Integer
enumValInt EnumVal
y)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") should be greater than "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ident -> String
forall a. Display a => a -> String
display (EnumVal -> Ident
enumValIdent EnumVal
x)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display (EnumVal -> Integer
enumValInt EnumVal
x)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"

    validateBounds :: EnumType -> EnumVal -> Validation ()
    validateBounds :: EnumType -> EnumVal -> Validation ()
validateBounds EnumType
enumType EnumVal
enumVal =
      EnumVal -> Validation () -> Validation ()
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating EnumVal
enumVal (Validation () -> Validation ()) -> Validation () -> Validation ()
forall a b. (a -> b) -> a -> b
$
        case EnumType
enumType of
          EnumType
EInt8 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Int8 EnumVal
enumVal
          EnumType
EInt16 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Int16 EnumVal
enumVal
          EnumType
EInt32 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Int32 EnumVal
enumVal
          EnumType
EInt64 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Int64 EnumVal
enumVal
          EnumType
EWord8 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Word8 EnumVal
enumVal
          EnumType
EWord16 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Word16 EnumVal
enumVal
          EnumType
EWord32 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Word32 EnumVal
enumVal
          EnumType
EWord64 -> EnumVal -> Validation ()
forall a.
(FiniteBits a, Integral a, Bounded a) =>
EnumVal -> Validation ()
validateBounds' @Word64 EnumVal
enumVal

    validateBounds' :: forall a. (FiniteBits a, Integral a, Bounded a) => EnumVal -> Validation ()
    validateBounds' :: EnumVal -> Validation ()
validateBounds' EnumVal
e =
      if (Integer, Integer) -> Integer -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Integer
lower, Integer
upper) (EnumVal -> Integer
enumValInt EnumVal
e)
        then () -> Validation ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        else String -> Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation ()) -> String -> Validation ()
forall a b. (a -> b) -> a -> b
$
              String
"enum value of "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display (EnumVal -> Integer
enumValInt EnumVal
e)
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" does not fit ["
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display Integer
lower
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display Integer
upper
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]"
      where
        lower :: Integer
lower = if Bool
isBitFlags
                  then Integer
0
                  else a -> Integer
forall a. Integral a => a -> Integer
toInteger (Bounded a => a
forall a. Bounded a => a
minBound @a)
        upper :: Integer
upper = if Bool
isBitFlags
                  then Int -> Integer
forall a. Integral a => a -> Integer
toInteger (a -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize @a (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                  else a -> Integer
forall a. Integral a => a -> Integer
toInteger (Bounded a => a
forall a. Bounded a => a
maxBound @a)

    validateEnumType :: ST.Type -> Validation EnumType
    validateEnumType :: Type -> Validation EnumType
validateEnumType Type
t =
      case Type
t of
        Type
ST.TInt8   -> EnumType -> Validation EnumType
forall (m :: * -> *) a. MonadValidation m => a -> m a
unlessIsBitFlags EnumType
EInt8
        Type
ST.TInt16  -> EnumType -> Validation EnumType
forall (m :: * -> *) a. MonadValidation m => a -> m a
unlessIsBitFlags EnumType
EInt16
        Type
ST.TInt32  -> EnumType -> Validation EnumType
forall (m :: * -> *) a. MonadValidation m => a -> m a
unlessIsBitFlags EnumType
EInt32
        Type
ST.TInt64  -> EnumType -> Validation EnumType
forall (m :: * -> *) a. MonadValidation m => a -> m a
unlessIsBitFlags EnumType
EInt64
        Type
ST.TWord8  -> EnumType -> Validation EnumType
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumType
EWord8
        Type
ST.TWord16 -> EnumType -> Validation EnumType
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumType
EWord16
        Type
ST.TWord32 -> EnumType -> Validation EnumType
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumType
EWord32
        Type
ST.TWord64 -> EnumType -> Validation EnumType
forall (f :: * -> *) a. Applicative f => a -> f a
pure EnumType
EWord64
        Type
_          -> String -> Validation EnumType
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"underlying enum type must be integral"
      where
        unlessIsBitFlags :: a -> m a
unlessIsBitFlags a
x =
          if Bool
isBitFlags
            then String -> m a
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"underlying type of bit_flags enum must be unsigned"
            else a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

    -- If this enum has the `bit_flags` attribute, convert its int value to the corresponding bitmask.
    -- E.g., 2 -> 00000100
    shiftBitFlags :: EnumVal -> EnumVal
    shiftBitFlags :: EnumVal -> EnumVal
shiftBitFlags EnumVal
e =
      if Bool
isBitFlags
        then EnumVal
e { enumValInt :: Integer
enumValInt = Int -> Integer
forall a. Bits a => Int -> a
bit (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer @Int (EnumVal -> Integer
enumValInt EnumVal
e)) }
        else EnumVal
e

    checkDuplicateFields :: Validation ()
    checkDuplicateFields :: Validation ()
checkDuplicateFields =
      NonEmpty EnumVal -> Validation ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadValidation m, Foldable f, Functor f, HasIdent a) =>
f a -> m ()
checkDuplicateIdentifiers
        (EnumDecl -> NonEmpty EnumVal
ST.enumVals EnumDecl
enum)


----------------------------------
------------ Tables --------------
----------------------------------
data TableFieldWithoutId = TableFieldWithoutId !Ident !TableFieldType !Bool

validateTables :: FileTree Stage3 -> Validation (FileTree Stage4)
validateTables :: FileTree Stage3 -> Validation (FileTree Stage4)
validateTables FileTree Stage3
symbolTables =
  FileTree Stage3
-> (Stage3 -> Validation Stage4) -> Validation (FileTree Stage4)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FileTree Stage3
symbolTables ((Stage3 -> Validation Stage4) -> Validation (FileTree Stage4))
-> (Stage3 -> Validation Stage4) -> Validation (FileTree Stage4)
forall a b. (a -> b) -> a -> b
$ \Stage3
symbolTable -> do
    Map (Namespace, Ident) TableDecl
validTables <- ((Namespace, Ident) -> TableDecl -> Validation TableDecl)
-> Map (Namespace, Ident) TableDecl
-> Validation (Map (Namespace, Ident) TableDecl)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (FileTree Stage3
-> (Namespace, Ident) -> TableDecl -> Validation TableDecl
validateTable FileTree Stage3
symbolTables) (Stage3 -> Map (Namespace, Ident) TableDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) table
allTables Stage3
symbolTable)
    Stage4 -> Validation Stage4
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stage3
symbolTable { allTables :: Map (Namespace, Ident) TableDecl
allTables = Map (Namespace, Ident) TableDecl
validTables }

validateTable :: FileTree Stage3 -> (Namespace, Ident) -> ST.TableDecl -> Validation TableDecl
validateTable :: FileTree Stage3
-> (Namespace, Ident) -> TableDecl -> Validation TableDecl
validateTable FileTree Stage3
symbolTables (Namespace
currentNamespace, Ident
_) TableDecl
table =
  Ident -> Validation TableDecl -> Validation TableDecl
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating (Namespace -> TableDecl -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify Namespace
currentNamespace TableDecl
table) (Validation TableDecl -> Validation TableDecl)
-> Validation TableDecl -> Validation TableDecl
forall a b. (a -> b) -> a -> b
$ do

    let fields :: [TableField]
fields = TableDecl -> [TableField]
ST.tableFields TableDecl
table
    let fieldsMetadata :: [Metadata]
fieldsMetadata = TableField -> Metadata
ST.tableFieldMetadata (TableField -> Metadata) -> [TableField] -> [Metadata]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TableField]
fields

    [TableField] -> Validation ()
checkDuplicateFields [TableField]
fields
    TableDecl -> Validation ()
forall (m :: * -> *) a.
(MonadValidation m, HasMetadata a) =>
a -> m ()
checkUndeclaredAttributes TableDecl
table

    [TableFieldWithoutId]
validFieldsWithoutIds <- (TableField -> Validation TableFieldWithoutId)
-> [TableField] -> Validation [TableFieldWithoutId]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TableField -> Validation TableFieldWithoutId
validateTableField [TableField]
fields
    [TableField]
validFields <- [Metadata] -> [TableFieldWithoutId] -> Validation [TableField]
assignFieldIds [Metadata]
fieldsMetadata [TableFieldWithoutId]
validFieldsWithoutIds

    TableDecl -> Validation TableDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure TableDecl :: Ident -> IsRoot -> [TableField] -> TableDecl
TableDecl
      { tableIdent :: Ident
tableIdent = TableDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent TableDecl
table
      , tableIsRoot :: IsRoot
tableIsRoot = IsRoot
NotRoot
      , tableFields :: [TableField]
tableFields = [TableField]
validFields
      }

  where
    checkDuplicateFields :: [ST.TableField] -> Validation ()
    checkDuplicateFields :: [TableField] -> Validation ()
checkDuplicateFields = [TableField] -> Validation ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadValidation m, Foldable f, Functor f, HasIdent a) =>
f a -> m ()
checkDuplicateIdentifiers

    assignFieldIds :: [ST.Metadata] -> [TableFieldWithoutId] -> Validation [TableField]
    assignFieldIds :: [Metadata] -> [TableFieldWithoutId] -> Validation [TableField]
assignFieldIds [Metadata]
metadata [TableFieldWithoutId]
fieldsWithoutIds = do
      [Integer]
ids <- [Maybe Integer] -> [Integer]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Integer] -> [Integer])
-> Validation [Maybe Integer] -> Validation [Integer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Metadata -> Validation (Maybe Integer))
-> [Metadata] -> Validation [Maybe Integer]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> Metadata -> Validation (Maybe Integer)
forall (m :: * -> *).
MonadValidation m =>
Text -> Metadata -> m (Maybe Integer)
findIntAttr Text
idAttr) [Metadata]
metadata
      if [Integer] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Integer]
ids
        then [TableField] -> Validation [TableField]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TableField] -> Validation [TableField])
-> [TableField] -> Validation [TableField]
forall a b. (a -> b) -> a -> b
$ State Integer [TableField] -> Integer -> [TableField]
forall s a. State s a -> s -> a
evalState ((TableFieldWithoutId -> StateT Integer Identity TableField)
-> [TableFieldWithoutId] -> State Integer [TableField]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TableFieldWithoutId -> StateT Integer Identity TableField
assignFieldId [TableFieldWithoutId]
fieldsWithoutIds) (-Integer
1)
        else if [Integer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
ids Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [TableFieldWithoutId] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TableFieldWithoutId]
fieldsWithoutIds
          then do
            let fields :: [TableField]
fields = (TableFieldWithoutId -> Integer -> TableField)
-> [TableFieldWithoutId] -> [Integer] -> [TableField]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(TableFieldWithoutId Ident
ident TableFieldType
typ Bool
depr) Integer
id -> Integer -> Ident -> TableFieldType -> Bool -> TableField
TableField Integer
id Ident
ident TableFieldType
typ Bool
depr) [TableFieldWithoutId]
fieldsWithoutIds [Integer]
ids
            let sorted :: [TableField]
sorted = (TableField -> Integer) -> [TableField] -> [TableField]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn TableField -> Integer
tableFieldId [TableField]
fields
            StateT Integer Validation () -> Integer -> Validation ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ((TableField -> StateT Integer Validation ())
-> [TableField] -> StateT Integer Validation ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TableField -> StateT Integer Validation ()
checkFieldId [TableField]
sorted) (-Integer
1)
            [TableField] -> Validation [TableField]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TableField]
sorted
          else
            String -> Validation [TableField]
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"either all fields or no fields must have an 'id' attribute"

    assignFieldId :: TableFieldWithoutId -> State Integer TableField
    assignFieldId :: TableFieldWithoutId -> StateT Integer Identity TableField
assignFieldId (TableFieldWithoutId Ident
ident TableFieldType
typ Bool
depr) = do
      Integer
lastId <- StateT Integer Identity Integer
forall s (m :: * -> *). MonadState s m => m s
get
      let fieldId :: Integer
fieldId =
            case TableFieldType
typ of
              TUnion TypeRef
_ Required
_           -> Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2
              TVector Required
_ (VUnion TypeRef
_) -> Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2
              TableFieldType
_                    -> Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
      Integer -> StateT Integer Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Integer
fieldId
      TableField -> StateT Integer Identity TableField
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Ident -> TableFieldType -> Bool -> TableField
TableField Integer
fieldId Ident
ident TableFieldType
typ Bool
depr)

    checkFieldId :: TableField -> StateT Integer Validation ()
    checkFieldId :: TableField -> StateT Integer Validation ()
checkFieldId TableField
field = do
      Integer
lastId <- StateT Integer Validation Integer
forall s (m :: * -> *). MonadState s m => m s
get
      TableField
-> StateT Integer Validation () -> StateT Integer Validation ()
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating TableField
field (StateT Integer Validation () -> StateT Integer Validation ())
-> StateT Integer Validation () -> StateT Integer Validation ()
forall a b. (a -> b) -> a -> b
$ do
        case TableField -> TableFieldType
tableFieldType TableField
field of
          TUnion TypeRef
_ Required
_ ->
            Bool
-> StateT Integer Validation () -> StateT Integer Validation ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TableField -> Integer
tableFieldId TableField
field Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2) (StateT Integer Validation () -> StateT Integer Validation ())
-> StateT Integer Validation () -> StateT Integer Validation ()
forall a b. (a -> b) -> a -> b
$
              String -> StateT Integer Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"the id of a union field must be the last field's id + 2"
          TVector Required
_ (VUnion TypeRef
_) ->
            Bool
-> StateT Integer Validation () -> StateT Integer Validation ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TableField -> Integer
tableFieldId TableField
field Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2) (StateT Integer Validation () -> StateT Integer Validation ())
-> StateT Integer Validation () -> StateT Integer Validation ()
forall a b. (a -> b) -> a -> b
$
              String -> StateT Integer Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"the id of a vector of unions field must be the last field's id + 2"
          TableFieldType
_ ->
            Bool
-> StateT Integer Validation () -> StateT Integer Validation ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TableField -> Integer
tableFieldId TableField
field Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) (StateT Integer Validation () -> StateT Integer Validation ())
-> StateT Integer Validation () -> StateT Integer Validation ()
forall a b. (a -> b) -> a -> b
$
              String -> StateT Integer Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> StateT Integer Validation ())
-> String -> StateT Integer Validation ()
forall a b. (a -> b) -> a -> b
$ String
"field ids must be consecutive from 0; id " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display (Integer
lastId Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is missing"
        Integer -> StateT Integer Validation ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (TableField -> Integer
tableFieldId TableField
field)

    validateTableField :: ST.TableField -> Validation TableFieldWithoutId
    validateTableField :: TableField -> Validation TableFieldWithoutId
validateTableField TableField
tf =
      TableField
-> Validation TableFieldWithoutId -> Validation TableFieldWithoutId
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating TableField
tf (Validation TableFieldWithoutId -> Validation TableFieldWithoutId)
-> Validation TableFieldWithoutId -> Validation TableFieldWithoutId
forall a b. (a -> b) -> a -> b
$ do
        TableField -> Validation ()
forall (m :: * -> *) a.
(MonadValidation m, HasMetadata a) =>
a -> m ()
checkUndeclaredAttributes TableField
tf
        TableFieldType
validFieldType <- Metadata -> Maybe DefaultVal -> Type -> Validation TableFieldType
validateTableFieldType (TableField -> Metadata
ST.tableFieldMetadata TableField
tf) (TableField -> Maybe DefaultVal
ST.tableFieldDefault TableField
tf) (TableField -> Type
ST.tableFieldType TableField
tf)

        TableFieldWithoutId -> Validation TableFieldWithoutId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableFieldWithoutId -> Validation TableFieldWithoutId)
-> TableFieldWithoutId -> Validation TableFieldWithoutId
forall a b. (a -> b) -> a -> b
$ Ident -> TableFieldType -> Bool -> TableFieldWithoutId
TableFieldWithoutId
          (TableField -> Ident
forall a. HasIdent a => a -> Ident
getIdent TableField
tf)
          TableFieldType
validFieldType
          (Text -> Metadata -> Bool
hasAttribute Text
deprecatedAttr (TableField -> Metadata
ST.tableFieldMetadata TableField
tf))

    validateTableFieldType :: ST.Metadata -> Maybe ST.DefaultVal -> ST.Type -> Validation TableFieldType
    validateTableFieldType :: Metadata -> Maybe DefaultVal -> Type -> Validation TableFieldType
validateTableFieldType Metadata
md Maybe DefaultVal
dflt Type
tableFieldType =
      case Type
tableFieldType of
        Type
ST.TInt8 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Int8 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TInt8
        Type
ST.TInt16 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Int16 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TInt16
        Type
ST.TInt32 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Int32 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TInt32
        Type
ST.TInt64 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Int64 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TInt64
        Type
ST.TWord8 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Word8 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TWord8
        Type
ST.TWord16 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Word16 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TWord16
        Type
ST.TWord32 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Word32 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TWord32
        Type
ST.TWord64 -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Integer)
-> Validation (DefaultVal Integer)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt @Word64 Maybe DefaultVal
dflt Validation (DefaultVal Integer)
-> (DefaultVal Integer -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Integer -> TableFieldType
TWord64
        Type
ST.TFloat -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Scientific)
-> Validation (DefaultVal Scientific)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Scientific)
validateDefaultValAsScientific Maybe DefaultVal
dflt Validation (DefaultVal Scientific)
-> (DefaultVal Scientific -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Scientific -> TableFieldType
TFloat
        Type
ST.TDouble -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Scientific)
-> Validation (DefaultVal Scientific)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Scientific)
validateDefaultValAsScientific Maybe DefaultVal
dflt Validation (DefaultVal Scientific)
-> (DefaultVal Scientific -> TableFieldType)
-> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Scientific -> TableFieldType
TDouble
        Type
ST.TBool -> Metadata -> Validation ()
checkNoRequired Metadata
md Validation ()
-> Validation (DefaultVal Bool) -> Validation (DefaultVal Bool)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe DefaultVal -> Validation (DefaultVal Bool)
validateDefaultValAsBool Maybe DefaultVal
dflt Validation (DefaultVal Bool)
-> (DefaultVal Bool -> TableFieldType) -> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> DefaultVal Bool -> TableFieldType
TBool
        Type
ST.TString -> Maybe DefaultVal -> Validation ()
checkNoDefault Maybe DefaultVal
dflt Validation () -> TableFieldType -> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Required -> TableFieldType
TString (Metadata -> Required
isRequired Metadata
md)
        ST.TRef TypeRef
typeRef ->
          Namespace
-> FileTree Stage3
-> TypeRef
-> Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
forall (m :: * -> *) e s t u.
MonadValidation m =>
Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree Stage3
symbolTables TypeRef
typeRef Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
-> (Match EnumDecl StructDecl TableDecl UnionDecl
    -> Validation TableFieldType)
-> Validation TableFieldType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            MatchE Namespace
ns EnumDecl
enum -> do
              Metadata -> Validation ()
checkNoRequired Metadata
md
              DefaultVal Integer
validDefault <- Maybe DefaultVal -> EnumDecl -> Validation (DefaultVal Integer)
validateDefaultAsEnum Maybe DefaultVal
dflt EnumDecl
enum
              TableFieldType -> Validation TableFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TableFieldType -> Validation TableFieldType)
-> TableFieldType -> Validation TableFieldType
forall a b. (a -> b) -> a -> b
$ TypeRef -> EnumType -> DefaultVal Integer -> TableFieldType
TEnum (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (EnumDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumDecl
enum)) (EnumDecl -> EnumType
enumType EnumDecl
enum) DefaultVal Integer
validDefault
            MatchS Namespace
ns StructDecl
struct -> Maybe DefaultVal -> Validation ()
checkNoDefault Maybe DefaultVal
dflt Validation () -> TableFieldType -> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TypeRef -> Required -> TableFieldType
TStruct (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
struct))  (Metadata -> Required
isRequired Metadata
md)
            MatchT Namespace
ns TableDecl
table  -> Maybe DefaultVal -> Validation ()
checkNoDefault Maybe DefaultVal
dflt Validation () -> TableFieldType -> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TypeRef -> Required -> TableFieldType
TTable  (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (TableDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent TableDecl
table)) (Metadata -> Required
isRequired Metadata
md)
            MatchU Namespace
ns UnionDecl
union  -> Maybe DefaultVal -> Validation ()
checkNoDefault Maybe DefaultVal
dflt Validation () -> TableFieldType -> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TypeRef -> Required -> TableFieldType
TUnion  (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (UnionDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent UnionDecl
union)) (Metadata -> Required
isRequired Metadata
md)
        ST.TVector Type
vecType ->
          Maybe DefaultVal -> Validation ()
checkNoDefault Maybe DefaultVal
dflt Validation ()
-> Validation TableFieldType -> Validation TableFieldType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Required -> VectorElementType -> TableFieldType
TVector (Metadata -> Required
isRequired Metadata
md) (VectorElementType -> TableFieldType)
-> Validation VectorElementType -> Validation TableFieldType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            case Type
vecType of
              Type
ST.TInt8 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VInt8
              Type
ST.TInt16 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VInt16
              Type
ST.TInt32 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VInt32
              Type
ST.TInt64 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VInt64
              Type
ST.TWord8 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VWord8
              Type
ST.TWord16 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VWord16
              Type
ST.TWord32 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VWord32
              Type
ST.TWord64 -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VWord64
              Type
ST.TFloat -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VFloat
              Type
ST.TDouble -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VDouble
              Type
ST.TBool -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VBool
              Type
ST.TString -> VectorElementType -> Validation VectorElementType
forall (f :: * -> *) a. Applicative f => a -> f a
pure VectorElementType
VString
              ST.TVector Type
_ -> String -> Validation VectorElementType
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"nested vector types not supported"
              ST.TRef TypeRef
typeRef ->
                Namespace
-> FileTree Stage3
-> TypeRef
-> Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
forall (m :: * -> *) e s t u.
MonadValidation m =>
Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree Stage3
symbolTables TypeRef
typeRef Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
-> (Match EnumDecl StructDecl TableDecl UnionDecl
    -> VectorElementType)
-> Validation VectorElementType
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                  MatchE Namespace
ns EnumDecl
enum ->
                    TypeRef -> EnumType -> VectorElementType
VEnum (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (EnumDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumDecl
enum))
                          (EnumDecl -> EnumType
enumType EnumDecl
enum)
                  MatchS Namespace
ns StructDecl
struct ->
                    TypeRef -> VectorElementType
VStruct (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
struct))
                  MatchT Namespace
ns TableDecl
table -> TypeRef -> VectorElementType
VTable (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (TableDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent TableDecl
table))
                  MatchU Namespace
ns UnionDecl
union -> TypeRef -> VectorElementType
VUnion (Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (UnionDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent UnionDecl
union))

checkNoRequired :: ST.Metadata -> Validation ()
checkNoRequired :: Metadata -> Validation ()
checkNoRequired Metadata
md =
  Bool -> Validation () -> Validation ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Metadata -> Bool
hasAttribute Text
requiredAttr Metadata
md) (Validation () -> Validation ()) -> Validation () -> Validation ()
forall a b. (a -> b) -> a -> b
$
    String -> Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"only non-scalar fields (strings, vectors, unions, structs, tables) may be 'required'"

checkNoDefault :: Maybe ST.DefaultVal -> Validation ()
checkNoDefault :: Maybe DefaultVal -> Validation ()
checkNoDefault Maybe DefaultVal
dflt =
  Bool -> Validation () -> Validation ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe DefaultVal -> Bool
forall a. Maybe a -> Bool
isJust Maybe DefaultVal
dflt) (Validation () -> Validation ()) -> Validation () -> Validation ()
forall a b. (a -> b) -> a -> b
$
    String -> Validation ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg
      String
"default values currently only supported for scalar fields (integers, floating point, bool, enums)"

isRequired :: ST.Metadata -> Required
isRequired :: Metadata -> Required
isRequired Metadata
md = if Text -> Metadata -> Bool
hasAttribute Text
requiredAttr Metadata
md then Required
Req else Required
Opt

validateDefaultValAsInt :: forall a. (Integral a, Bounded a, Display a) => Maybe ST.DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt :: Maybe DefaultVal -> Validation (DefaultVal Integer)
validateDefaultValAsInt Maybe DefaultVal
dflt =
  case Maybe DefaultVal
dflt of
    Maybe DefaultVal
Nothing                -> DefaultVal Integer -> Validation (DefaultVal Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DefaultVal Integer
forall a. a -> DefaultVal a
DefaultVal Integer
0)
    Just (ST.DefaultNum Scientific
n) -> Scientific -> String -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger @a Scientific
n String
"default value must be integral"
    Just DefaultVal
_                 -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"default value must be integral"

validateDefaultValAsScientific :: Maybe ST.DefaultVal -> Validation (DefaultVal Scientific)
validateDefaultValAsScientific :: Maybe DefaultVal -> Validation (DefaultVal Scientific)
validateDefaultValAsScientific Maybe DefaultVal
dflt =
  case Maybe DefaultVal
dflt of
    Maybe DefaultVal
Nothing                 -> DefaultVal Scientific -> Validation (DefaultVal Scientific)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> DefaultVal Scientific
forall a. a -> DefaultVal a
DefaultVal Scientific
0)
    Just (ST.DefaultNum Scientific
n)  -> DefaultVal Scientific -> Validation (DefaultVal Scientific)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Scientific -> DefaultVal Scientific
forall a. a -> DefaultVal a
DefaultVal Scientific
n)
    Just DefaultVal
_                  -> String -> Validation (DefaultVal Scientific)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"default value must be a number"

validateDefaultValAsBool :: Maybe ST.DefaultVal -> Validation (DefaultVal Bool)
validateDefaultValAsBool :: Maybe DefaultVal -> Validation (DefaultVal Bool)
validateDefaultValAsBool Maybe DefaultVal
dflt =
  case Maybe DefaultVal
dflt of
    Maybe DefaultVal
Nothing                 -> DefaultVal Bool -> Validation (DefaultVal Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DefaultVal Bool
forall a. a -> DefaultVal a
DefaultVal Bool
False)
    Just (ST.DefaultBool Bool
b) -> DefaultVal Bool -> Validation (DefaultVal Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> DefaultVal Bool
forall a. a -> DefaultVal a
DefaultVal Bool
b)
    Just DefaultVal
_                  -> String -> Validation (DefaultVal Bool)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"default value must be a boolean"

validateDefaultAsEnum :: Maybe ST.DefaultVal -> EnumDecl -> Validation (DefaultVal Integer)
validateDefaultAsEnum :: Maybe DefaultVal -> EnumDecl -> Validation (DefaultVal Integer)
validateDefaultAsEnum Maybe DefaultVal
dflt EnumDecl
enum =
  case Maybe DefaultVal
dflt of
    Maybe DefaultVal
Nothing ->
      if EnumDecl -> Bool
enumBitFlags EnumDecl
enum
        then DefaultVal Integer -> Validation (DefaultVal Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefaultVal Integer
0
        else
          case (EnumVal -> Bool) -> NonEmpty EnumVal -> Maybe EnumVal
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\EnumVal
val -> EnumVal -> Integer
enumValInt EnumVal
val Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) (EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum) of
            Just EnumVal
_  -> DefaultVal Integer -> Validation (DefaultVal Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefaultVal Integer
0
            Maybe EnumVal
Nothing -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"enum does not have a 0 value; please manually specify a default for this field"
    Just (ST.DefaultNum Scientific
n) ->
      if EnumDecl -> Bool
enumBitFlags EnumDecl
enum
        then
          case EnumDecl -> EnumType
enumType EnumDecl
enum of
            EnumType
EWord8  -> Scientific -> String -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger @Word8  Scientific
n String
defaultErrorMsg
            EnumType
EWord16 -> Scientific -> String -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger @Word16 Scientific
n String
defaultErrorMsg
            EnumType
EWord32 -> Scientific -> String -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger @Word32 Scientific
n String
defaultErrorMsg
            EnumType
EWord64 -> Scientific -> String -> Validation (DefaultVal Integer)
forall a.
(Integral a, Bounded a, Display a) =>
Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger @Word64 Scientific
n String
defaultErrorMsg
            EnumType
_       -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"The 'impossible' has happened: bit_flags enum with signed integer"
        else
          case Scientific -> Either Float Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
Scientific.floatingOrInteger @Float Scientific
n of
            Left Float
_float -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
defaultErrorMsg
            Right Integer
i ->
              case (EnumVal -> Bool) -> NonEmpty EnumVal -> Maybe EnumVal
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\EnumVal
val -> EnumVal -> Integer
enumValInt EnumVal
val Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i) (EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum) of
                Just EnumVal
matchingVal -> DefaultVal Integer -> Validation (DefaultVal Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DefaultVal Integer
forall a. a -> DefaultVal a
DefaultVal (EnumVal -> Integer
enumValInt EnumVal
matchingVal))
                Maybe EnumVal
Nothing -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation (DefaultVal Integer))
-> String -> Validation (DefaultVal Integer)
forall a b. (a -> b) -> a -> b
$ String
"default value of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Integer -> String
forall a. Display a => a -> String
display Integer
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not part of enum " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ident -> String
forall a. Display a => a -> String
display (EnumDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumDecl
enum)
    Just (ST.DefaultRef NonEmpty Text
refs) ->
      if EnumDecl -> Bool
enumBitFlags EnumDecl
enum
        then
          (DefaultVal Integer -> DefaultVal Integer -> DefaultVal Integer)
-> NonEmpty (DefaultVal Integer) -> DefaultVal Integer
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 DefaultVal Integer -> DefaultVal Integer -> DefaultVal Integer
forall a. Bits a => a -> a -> a
(.|.) (NonEmpty (DefaultVal Integer) -> DefaultVal Integer)
-> Validation (NonEmpty (DefaultVal Integer))
-> Validation (DefaultVal Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Validation (DefaultVal Integer))
-> NonEmpty Text -> Validation (NonEmpty (DefaultVal Integer))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Validation (DefaultVal Integer)
findEnumByRef NonEmpty Text
refs
        else
          case NonEmpty Text
refs of
            Text
ref :| [] -> Text -> Validation (DefaultVal Integer)
findEnumByRef Text
ref
            NonEmpty Text
_         -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation (DefaultVal Integer))
-> String -> Validation (DefaultVal Integer)
forall a b. (a -> b) -> a -> b
$ String
"default value must be a single identifier, found "
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Display a => a -> String
display (NonEmpty Text -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty Text
refs)
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": "
                          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> String
forall a. Display a => a -> String
display ((Text -> Text) -> NonEmpty Text -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
ref -> Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'") NonEmpty Text
refs)
    Just (ST.DefaultBool Bool
_) ->
      String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
defaultErrorMsg
  where
    defaultErrorMsg :: String
defaultErrorMsg =
      if EnumDecl -> Bool
enumBitFlags EnumDecl
enum
        then case EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum of
          EnumVal
x :| EnumVal
y : [EnumVal]
_ ->
            String
"default value must be integral, one of ["
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Ident -> String
forall a. Display a => a -> String
display (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent (EnumVal -> Ident) -> NonEmpty EnumVal -> NonEmpty Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"], or a combination of the latter in double quotes (e.g. \""
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Ident -> Text
unIdent (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumVal
x))
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack (Ident -> Text
unIdent (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumVal
y))
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\")"
          NonEmpty EnumVal
_ ->
            String
"default value must be integral or one of: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Ident -> String
forall a. Display a => a -> String
display (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent (EnumVal -> Ident) -> NonEmpty EnumVal -> NonEmpty Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum)
        else
          String
"default value must be integral or one of: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty Ident -> String
forall a. Display a => a -> String
display (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent (EnumVal -> Ident) -> NonEmpty EnumVal -> NonEmpty Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum)

    findEnumByRef :: Text -> Validation (DefaultVal Integer)
    findEnumByRef :: Text -> Validation (DefaultVal Integer)
findEnumByRef Text
ref =
      case (EnumVal -> Bool) -> NonEmpty EnumVal -> Maybe EnumVal
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\EnumVal
val -> Ident -> Text
unIdent (EnumVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumVal
val) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
ref) (EnumDecl -> NonEmpty EnumVal
enumVals EnumDecl
enum) of
        Just EnumVal
matchingVal -> DefaultVal Integer -> Validation (DefaultVal Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DefaultVal Integer
forall a. a -> DefaultVal a
DefaultVal (EnumVal -> Integer
enumValInt EnumVal
matchingVal))
        Maybe EnumVal
Nothing          -> String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation (DefaultVal Integer))
-> String -> Validation (DefaultVal Integer)
forall a b. (a -> b) -> a -> b
$ String
"default value of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display Text
ref String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not part of enum " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Ident -> String
forall a. Display a => a -> String
display (EnumDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumDecl
enum)

scientificToInteger ::
  forall a. (Integral a, Bounded a, Display a)
  => Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger :: Scientific -> String -> Validation (DefaultVal Integer)
scientificToInteger Scientific
n String
notIntegerErrorMsg =
  if Bool -> Bool
not (Scientific -> Bool
Scientific.isInteger Scientific
n)
    then String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
notIntegerErrorMsg
    else
      case Scientific -> Maybe a
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
Scientific.toBoundedInteger @a Scientific
n of
        Maybe a
Nothing ->
          String -> Validation (DefaultVal Integer)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation (DefaultVal Integer))
-> String -> Validation (DefaultVal Integer)
forall a b. (a -> b) -> a -> b
$
            String
"default value does not fit ["
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Display a => a -> String
display (Bounded a => a
forall a. Bounded a => a
minBound @a)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Display a => a -> String
display (Bounded a => a
forall a. Bounded a => a
maxBound @a)
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]"
        Just a
i -> DefaultVal Integer -> Validation (DefaultVal Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> DefaultVal Integer
forall a. a -> DefaultVal a
DefaultVal (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
i))

----------------------------------
------------ Unions --------------
----------------------------------
validateUnions :: FileTree Stage4 -> Validation (FileTree ValidDecls)
validateUnions :: FileTree Stage4 -> Validation (FileTree ValidDecls)
validateUnions FileTree Stage4
symbolTables =
  FileTree Stage4
-> (Stage4 -> Validation ValidDecls)
-> Validation (FileTree ValidDecls)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for FileTree Stage4
symbolTables ((Stage4 -> Validation ValidDecls)
 -> Validation (FileTree ValidDecls))
-> (Stage4 -> Validation ValidDecls)
-> Validation (FileTree ValidDecls)
forall a b. (a -> b) -> a -> b
$ \Stage4
symbolTable -> do
    Map (Namespace, Ident) UnionDecl
validUnions <- ((Namespace, Ident) -> UnionDecl -> Validation UnionDecl)
-> Map (Namespace, Ident) UnionDecl
-> Validation (Map (Namespace, Ident) UnionDecl)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (FileTree Stage4
-> (Namespace, Ident) -> UnionDecl -> Validation UnionDecl
validateUnion FileTree Stage4
symbolTables) (Stage4 -> Map (Namespace, Ident) UnionDecl
forall enum struct table union.
SymbolTable enum struct table union -> Map (Namespace, Ident) union
allUnions Stage4
symbolTable)
    ValidDecls -> Validation ValidDecls
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stage4
symbolTable { allUnions :: Map (Namespace, Ident) UnionDecl
allUnions = Map (Namespace, Ident) UnionDecl
validUnions }

validateUnion :: FileTree Stage4 -> (Namespace, Ident) -> ST.UnionDecl -> Validation UnionDecl
validateUnion :: FileTree Stage4
-> (Namespace, Ident) -> UnionDecl -> Validation UnionDecl
validateUnion FileTree Stage4
symbolTables (Namespace
currentNamespace, Ident
_) UnionDecl
union =
  Ident -> Validation UnionDecl -> Validation UnionDecl
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating (Namespace -> UnionDecl -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify Namespace
currentNamespace UnionDecl
union) (Validation UnionDecl -> Validation UnionDecl)
-> Validation UnionDecl -> Validation UnionDecl
forall a b. (a -> b) -> a -> b
$ do
    NonEmpty UnionVal
validUnionVals <- (UnionVal -> Validation UnionVal)
-> NonEmpty UnionVal -> Validation (NonEmpty UnionVal)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UnionVal -> Validation UnionVal
validateUnionVal (UnionDecl -> NonEmpty UnionVal
ST.unionVals UnionDecl
union)
    NonEmpty UnionVal -> Validation ()
checkDuplicateVals NonEmpty UnionVal
validUnionVals
    UnionDecl -> Validation ()
forall (m :: * -> *) a.
(MonadValidation m, HasMetadata a) =>
a -> m ()
checkUndeclaredAttributes UnionDecl
union
    UnionDecl -> Validation UnionDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnionDecl -> Validation UnionDecl)
-> UnionDecl -> Validation UnionDecl
forall a b. (a -> b) -> a -> b
$ UnionDecl :: Ident -> NonEmpty UnionVal -> UnionDecl
UnionDecl
      { unionIdent :: Ident
unionIdent = UnionDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent UnionDecl
union
      , unionVals :: NonEmpty UnionVal
unionVals = NonEmpty UnionVal
validUnionVals
      }
  where
    validateUnionVal :: ST.UnionVal -> Validation UnionVal
    validateUnionVal :: UnionVal -> Validation UnionVal
validateUnionVal UnionVal
uv = do
      let tref :: TypeRef
tref = UnionVal -> TypeRef
ST.unionValTypeRef UnionVal
uv
      let partiallyQualifiedTypeRef :: Ident
partiallyQualifiedTypeRef = Namespace -> Ident -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify (TypeRef -> Namespace
typeRefNamespace TypeRef
tref) (TypeRef -> Ident
typeRefIdent TypeRef
tref)
      let ident :: Ident
ident = Ident -> Maybe Ident -> Ident
forall a. a -> Maybe a -> a
fromMaybe Ident
partiallyQualifiedTypeRef (UnionVal -> Maybe Ident
ST.unionValIdent UnionVal
uv)
      let identFormatted :: Ident
identFormatted = Text -> Ident
coerce (Text -> Ident) -> Text -> Ident
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
T.replace Text
"." Text
"_" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Ident -> Text
coerce Ident
ident
      Ident -> Validation UnionVal -> Validation UnionVal
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating Ident
identFormatted (Validation UnionVal -> Validation UnionVal)
-> Validation UnionVal -> Validation UnionVal
forall a b. (a -> b) -> a -> b
$ do
        TypeRef
tableRef <- TypeRef -> Validation TypeRef
validateUnionValType TypeRef
tref
        UnionVal -> Validation UnionVal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnionVal -> Validation UnionVal)
-> UnionVal -> Validation UnionVal
forall a b. (a -> b) -> a -> b
$ UnionVal :: Ident -> TypeRef -> UnionVal
UnionVal
          { unionValIdent :: Ident
unionValIdent = Ident
identFormatted
          , unionValTableRef :: TypeRef
unionValTableRef = TypeRef
tableRef
          }

    validateUnionValType :: TypeRef -> Validation TypeRef
    validateUnionValType :: TypeRef -> Validation TypeRef
validateUnionValType TypeRef
typeRef =
      Namespace
-> FileTree Stage4
-> TypeRef
-> Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
forall (m :: * -> *) e s t u.
MonadValidation m =>
Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree Stage4
symbolTables TypeRef
typeRef Validation (Match EnumDecl StructDecl TableDecl UnionDecl)
-> (Match EnumDecl StructDecl TableDecl UnionDecl
    -> Validation TypeRef)
-> Validation TypeRef
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        MatchT Namespace
ns TableDecl
table -> TypeRef -> Validation TypeRef
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeRef -> Validation TypeRef) -> TypeRef -> Validation TypeRef
forall a b. (a -> b) -> a -> b
$ Namespace -> Ident -> TypeRef
TypeRef Namespace
ns (TableDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent TableDecl
table)
        Match EnumDecl StructDecl TableDecl UnionDecl
_               -> String -> Validation TypeRef
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"union members may only be tables"

    checkDuplicateVals :: NonEmpty UnionVal -> Validation ()
    checkDuplicateVals :: NonEmpty UnionVal -> Validation ()
checkDuplicateVals NonEmpty UnionVal
vals = NonEmpty Ident -> Validation ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadValidation m, Foldable f, Functor f, HasIdent a) =>
f a -> m ()
checkDuplicateIdentifiers (Ident -> NonEmpty Ident -> NonEmpty Ident
forall a. a -> NonEmpty a -> NonEmpty a
NE.cons Ident
"NONE" ((UnionVal -> Ident) -> NonEmpty UnionVal -> NonEmpty Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnionVal -> Ident
forall a. HasIdent a => a -> Ident
getIdent NonEmpty UnionVal
vals))


----------------------------------
------------ Structs -------------
----------------------------------

-- | Cache of already validated structs.
--
-- When we're validating a struct @A@, it may contain an inner struct @B@ which also needs validating.
-- @B@ needs to be fully validated before we can consider @A@ valid.
--
-- If we've validated @B@ in a previous iteration, we will find it in this Map
-- and therefore avoid re-validating it.
type ValidatedStructs = Map (Namespace, Ident) StructDecl


validateStructs :: FileTree Stage2 -> Validation (FileTree Stage3)
validateStructs :: FileTree Stage2 -> Validation (FileTree Stage3)
validateStructs FileTree Stage2
symbolTables =
  (StateT
   (Map (Namespace, Ident) StructDecl) Validation (FileTree Stage3)
 -> Map (Namespace, Ident) StructDecl
 -> Validation (FileTree Stage3))
-> Map (Namespace, Ident) StructDecl
-> StateT
     (Map (Namespace, Ident) StructDecl) Validation (FileTree Stage3)
-> Validation (FileTree Stage3)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (Map (Namespace, Ident) StructDecl) Validation (FileTree Stage3)
-> Map (Namespace, Ident) StructDecl
-> Validation (FileTree Stage3)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Map (Namespace, Ident) StructDecl
forall k a. Map k a
Map.empty (StateT
   (Map (Namespace, Ident) StructDecl) Validation (FileTree Stage3)
 -> Validation (FileTree Stage3))
-> StateT
     (Map (Namespace, Ident) StructDecl) Validation (FileTree Stage3)
-> Validation (FileTree Stage3)
forall a b. (a -> b) -> a -> b
$ (Stage2
 -> StateT (Map (Namespace, Ident) StructDecl) Validation Stage3)
-> FileTree Stage2
-> StateT
     (Map (Namespace, Ident) StructDecl) Validation (FileTree Stage3)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Stage2
-> StateT (Map (Namespace, Ident) StructDecl) Validation Stage3
validateFile FileTree Stage2
symbolTables
  where
  validateFile :: Stage2 -> StateT ValidatedStructs Validation Stage3
  validateFile :: Stage2
-> StateT (Map (Namespace, Ident) StructDecl) Validation Stage3
validateFile Stage2
symbolTable = do
    let structs :: Map (Namespace, Ident) StructDecl
structs = Stage2 -> Map (Namespace, Ident) StructDecl
forall enum struct table union.
SymbolTable enum struct table union
-> Map (Namespace, Ident) struct
allStructs Stage2
symbolTable

    (((Namespace, Ident), StructDecl)
 -> StateT (Map (Namespace, Ident) StructDecl) Validation ())
-> [((Namespace, Ident), StructDecl)]
-> StateT (Map (Namespace, Ident) StructDecl) Validation ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\((Namespace
ns, Ident
_), StructDecl
struct) -> FileTree Stage2
-> (Namespace, StructDecl)
-> StateT (Map (Namespace, Ident) StructDecl) Validation ()
forall (m :: * -> *).
MonadValidation m =>
FileTree Stage2 -> (Namespace, StructDecl) -> m ()
checkStructCycles FileTree Stage2
symbolTables (Namespace
ns, StructDecl
struct)) (Map (Namespace, Ident) StructDecl
-> [((Namespace, Ident), StructDecl)]
forall k a. Map k a -> [(k, a)]
Map.toList Map (Namespace, Ident) StructDecl
structs)
    Map (Namespace, Ident) StructDecl
validStructs <- ((Namespace, Ident)
 -> StructDecl
 -> StateT
      (Map (Namespace, Ident) StructDecl) Validation StructDecl)
-> Map (Namespace, Ident) StructDecl
-> StateT
     (Map (Namespace, Ident) StructDecl)
     Validation
     (Map (Namespace, Ident) StructDecl)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey (\(Namespace
ns, Ident
_) StructDecl
struct -> FileTree Stage2
-> Namespace
-> StructDecl
-> StateT (Map (Namespace, Ident) StructDecl) Validation StructDecl
forall (m :: * -> *).
(MonadState (Map (Namespace, Ident) StructDecl) m,
 MonadValidation m) =>
FileTree Stage2 -> Namespace -> StructDecl -> m StructDecl
validateStruct FileTree Stage2
symbolTables Namespace
ns StructDecl
struct) Map (Namespace, Ident) StructDecl
structs

    Stage3
-> StateT (Map (Namespace, Ident) StructDecl) Validation Stage3
forall (f :: * -> *) a. Applicative f => a -> f a
pure Stage2
symbolTable { allStructs :: Map (Namespace, Ident) StructDecl
allStructs = Map (Namespace, Ident) StructDecl
validStructs }

checkStructCycles :: forall m. MonadValidation m => FileTree Stage2 -> (Namespace, ST.StructDecl) -> m ()
checkStructCycles :: FileTree Stage2 -> (Namespace, StructDecl) -> m ()
checkStructCycles FileTree Stage2
symbolTables = [Ident] -> (Namespace, StructDecl) -> m ()
go []
  where
    go :: [Ident] -> (Namespace, ST.StructDecl) -> m ()
    go :: [Ident] -> (Namespace, StructDecl) -> m ()
go [Ident]
visited (Namespace
currentNamespace, StructDecl
struct) = do
      let qualifiedName :: Ident
qualifiedName = Namespace -> StructDecl -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify Namespace
currentNamespace StructDecl
struct
      m () -> m ()
forall (m :: * -> *) a. MonadValidation m => m a -> m a
resetContext (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        Ident -> m () -> m ()
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating Ident
qualifiedName (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
          if Ident
qualifiedName Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
visited
            then
              String -> m ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
                String
"cyclic dependency detected ["
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display (Text -> [Text] -> Text
T.intercalate Text
" -> " ([Text] -> Text) -> ([Ident] -> [Text]) -> [Ident] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Ident] -> [Text]
coerce ([Ident] -> Text) -> [Ident] -> Text
forall a b. (a -> b) -> a -> b
$ (Ident -> Bool) -> [Ident] -> [Ident]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhile (Ident -> Ident -> Bool
forall a. Eq a => a -> a -> Bool
/= Ident
qualifiedName) ([Ident] -> [Ident]) -> [Ident] -> [Ident]
forall a b. (a -> b) -> a -> b
$ [Ident] -> [Ident]
forall a. [a] -> [a]
List.reverse (Ident
qualifiedName Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: [Ident]
visited))
                String -> String -> String
forall a. Semigroup a => a -> a -> a
<>String
"] - structs cannot contain themselves, directly or indirectly"
            else
              NonEmpty StructField -> (StructField -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (StructDecl -> NonEmpty StructField
ST.structFields StructDecl
struct) ((StructField -> m ()) -> m ()) -> (StructField -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \StructField
field ->
                StructField -> m () -> m ()
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating StructField
field (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                  case StructField -> Type
ST.structFieldType StructField
field of
                    ST.TRef TypeRef
typeRef ->
                      Namespace
-> FileTree Stage2
-> TypeRef
-> m (Match EnumDecl StructDecl TableDecl UnionDecl)
forall (m :: * -> *) e s t u.
MonadValidation m =>
Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree Stage2
symbolTables TypeRef
typeRef m (Match EnumDecl StructDecl TableDecl UnionDecl)
-> (Match EnumDecl StructDecl TableDecl UnionDecl -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        MatchS Namespace
ns StructDecl
struct -> [Ident] -> (Namespace, StructDecl) -> m ()
go (Ident
qualifiedName Ident -> [Ident] -> [Ident]
forall a. a -> [a] -> [a]
: [Ident]
visited) (Namespace
ns, StructDecl
struct)
                        Match EnumDecl StructDecl TableDecl UnionDecl
_                -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- The TypeRef points to an enum (or is invalid), so no further validation is needed at this point
                    Type
_                    -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Field is not a TypeRef, no validation needed

data UnpaddedStructField = UnpaddedStructField
  { UnpaddedStructField -> Ident
unpaddedStructFieldIdent :: !Ident
  , UnpaddedStructField -> StructFieldType
unpaddedStructFieldType  :: !StructFieldType
  } deriving (Int -> UnpaddedStructField -> String -> String
[UnpaddedStructField] -> String -> String
UnpaddedStructField -> String
(Int -> UnpaddedStructField -> String -> String)
-> (UnpaddedStructField -> String)
-> ([UnpaddedStructField] -> String -> String)
-> Show UnpaddedStructField
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnpaddedStructField] -> String -> String
$cshowList :: [UnpaddedStructField] -> String -> String
show :: UnpaddedStructField -> String
$cshow :: UnpaddedStructField -> String
showsPrec :: Int -> UnpaddedStructField -> String -> String
$cshowsPrec :: Int -> UnpaddedStructField -> String -> String
Show, UnpaddedStructField -> UnpaddedStructField -> Bool
(UnpaddedStructField -> UnpaddedStructField -> Bool)
-> (UnpaddedStructField -> UnpaddedStructField -> Bool)
-> Eq UnpaddedStructField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnpaddedStructField -> UnpaddedStructField -> Bool
$c/= :: UnpaddedStructField -> UnpaddedStructField -> Bool
== :: UnpaddedStructField -> UnpaddedStructField -> Bool
$c== :: UnpaddedStructField -> UnpaddedStructField -> Bool
Eq)

validateStruct ::
     forall m. (MonadState ValidatedStructs m, MonadValidation m)
  => FileTree Stage2
  -> Namespace
  -> ST.StructDecl
  -> m StructDecl
validateStruct :: FileTree Stage2 -> Namespace -> StructDecl -> m StructDecl
validateStruct FileTree Stage2
symbolTables Namespace
currentNamespace StructDecl
struct =
  m StructDecl -> m StructDecl
forall (m :: * -> *) a. MonadValidation m => m a -> m a
resetContext (m StructDecl -> m StructDecl) -> m StructDecl -> m StructDecl
forall a b. (a -> b) -> a -> b
$
  Ident -> m StructDecl -> m StructDecl
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating (Namespace -> StructDecl -> Ident
forall a. HasIdent a => Namespace -> a -> Ident
qualify Namespace
currentNamespace StructDecl
struct) (m StructDecl -> m StructDecl) -> m StructDecl -> m StructDecl
forall a b. (a -> b) -> a -> b
$ do
    Map (Namespace, Ident) StructDecl
validStructs <- m (Map (Namespace, Ident) StructDecl)
forall s (m :: * -> *). MonadState s m => m s
get
    -- Check if this struct has already been validated in a previous iteration
    case (Namespace, Ident)
-> Map (Namespace, Ident) StructDecl -> Maybe StructDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Namespace
currentNamespace, StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
struct) Map (Namespace, Ident) StructDecl
validStructs of
      Just StructDecl
match -> StructDecl -> m StructDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructDecl
match
      Maybe StructDecl
Nothing -> do
        m ()
checkDuplicateFields
        StructDecl -> m ()
forall (m :: * -> *) a.
(MonadValidation m, HasMetadata a) =>
a -> m ()
checkUndeclaredAttributes StructDecl
struct

        NonEmpty UnpaddedStructField
fields <- (StructField -> m UnpaddedStructField)
-> NonEmpty StructField -> m (NonEmpty UnpaddedStructField)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse StructField -> m UnpaddedStructField
validateStructField (StructDecl -> NonEmpty StructField
ST.structFields StructDecl
struct)
        let naturalAlignment :: Alignment
naturalAlignment = NonEmpty Alignment -> Alignment
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (UnpaddedStructField -> Alignment
structFieldAlignment (UnpaddedStructField -> Alignment)
-> NonEmpty UnpaddedStructField -> NonEmpty Alignment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty UnpaddedStructField
fields)
        Maybe Integer
forceAlignAttrVal <- m (Maybe Integer)
getForceAlignAttr
        Maybe Alignment
forceAlign <- (Integer -> m Alignment) -> Maybe Integer -> m (Maybe Alignment)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Alignment -> Integer -> m Alignment
validateForceAlign Alignment
naturalAlignment) Maybe Integer
forceAlignAttrVal
        let alignment :: Alignment
alignment = Alignment -> Maybe Alignment -> Alignment
forall a. a -> Maybe a -> a
fromMaybe Alignment
naturalAlignment Maybe Alignment
forceAlign

        -- In order to calculate the padding between fields, we must first know the fields' and the struct's
        -- alignment. Which means we must first validate all the struct's fields, and then do a second
        -- pass to calculate the padding.
        let (InlineSize
size, NonEmpty StructField
paddedFields) = Alignment
-> NonEmpty UnpaddedStructField
-> (InlineSize, NonEmpty StructField)
addFieldPadding Alignment
alignment NonEmpty UnpaddedStructField
fields

        let validStruct :: StructDecl
validStruct = StructDecl :: Ident
-> Alignment -> InlineSize -> NonEmpty StructField -> StructDecl
StructDecl
              { structIdent :: Ident
structIdent      = StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
struct
              , structAlignment :: Alignment
structAlignment  = Alignment
alignment
              , structSize :: InlineSize
structSize       = InlineSize
size
              , structFields :: NonEmpty StructField
structFields     = NonEmpty StructField
paddedFields
              }
        (Map (Namespace, Ident) StructDecl
 -> Map (Namespace, Ident) StructDecl)
-> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Namespace, Ident)
-> StructDecl
-> Map (Namespace, Ident) StructDecl
-> Map (Namespace, Ident) StructDecl
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Namespace
currentNamespace, StructDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructDecl
validStruct) StructDecl
validStruct)
        StructDecl -> m StructDecl
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructDecl
validStruct

  where
    invalidStructFieldType :: String
invalidStructFieldType = String
"struct fields may only be integers, floating point, bool, enums, or other structs"

    -- | Calculates how much padding each field needs, and returns the struct's total size
    -- and a list of fields with padding information.
    addFieldPadding :: Alignment -> NonEmpty UnpaddedStructField -> (InlineSize, NonEmpty StructField)
    addFieldPadding :: Alignment
-> NonEmpty UnpaddedStructField
-> (InlineSize, NonEmpty StructField)
addFieldPadding Alignment
structAlignment NonEmpty UnpaddedStructField
unpaddedFields =
      (InlineSize
size, [StructField] -> NonEmpty StructField
forall a. [a] -> NonEmpty a
NE.fromList ([StructField] -> [StructField]
forall a. [a] -> [a]
reverse [StructField]
paddedFields))
      where

        (InlineSize
size, [StructField]
paddedFields) = InlineSize
-> [StructField]
-> [UnpaddedStructField]
-> (InlineSize, [StructField])
go InlineSize
0 [] (NonEmpty UnpaddedStructField -> [UnpaddedStructField]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty UnpaddedStructField
unpaddedFields)

        go :: InlineSize -> [StructField] -> [UnpaddedStructField] -> (InlineSize, [StructField])
        go :: InlineSize
-> [StructField]
-> [UnpaddedStructField]
-> (InlineSize, [StructField])
go InlineSize
size [StructField]
paddedFields [] = (InlineSize
size, [StructField]
paddedFields)
        go InlineSize
size [StructField]
paddedFields (UnpaddedStructField
x : UnpaddedStructField
y : [UnpaddedStructField]
tail) =
          let size' :: InlineSize
size' = InlineSize
size InlineSize -> InlineSize -> InlineSize
forall a. Num a => a -> a -> a
+ StructFieldType -> InlineSize
structFieldTypeSize (UnpaddedStructField -> StructFieldType
unpaddedStructFieldType UnpaddedStructField
x)
              nextFieldsAlignment :: InlineSize
nextFieldsAlignment = Alignment -> InlineSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Alignment @InlineSize (UnpaddedStructField -> Alignment
structFieldAlignment UnpaddedStructField
y)
              paddingNeeded :: InlineSize
paddingNeeded = (InlineSize
size' InlineSize -> InlineSize -> InlineSize
forall n. Integral n => n -> n -> n
`roundUpToNearestMultipleOf` InlineSize
nextFieldsAlignment) InlineSize -> InlineSize -> InlineSize
forall a. Num a => a -> a -> a
- InlineSize
size'
              size'' :: InlineSize
size'' = InlineSize
size' InlineSize -> InlineSize -> InlineSize
forall a. Num a => a -> a -> a
+ InlineSize
paddingNeeded
              paddedField :: StructField
paddedField = StructField :: Ident -> Word8 -> Word16 -> StructFieldType -> StructField
StructField
                { structFieldIdent :: Ident
structFieldIdent = UnpaddedStructField -> Ident
unpaddedStructFieldIdent UnpaddedStructField
x
                -- NOTE: it is safe to narrow `paddingNeeded` to a word8 here because it's always smaller than `nextFieldsAlignment`
                , structFieldPadding :: Word8
structFieldPadding = InlineSize -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral @InlineSize @Word8 InlineSize
paddingNeeded
                , structFieldOffset :: Word16
structFieldOffset = InlineSize -> Word16
coerce InlineSize
size
                , structFieldType :: StructFieldType
structFieldType = UnpaddedStructField -> StructFieldType
unpaddedStructFieldType UnpaddedStructField
x
                }
          in  InlineSize
-> [StructField]
-> [UnpaddedStructField]
-> (InlineSize, [StructField])
go InlineSize
size'' (StructField
paddedField StructField -> [StructField] -> [StructField]
forall a. a -> [a] -> [a]
: [StructField]
paddedFields) (UnpaddedStructField
y UnpaddedStructField
-> [UnpaddedStructField] -> [UnpaddedStructField]
forall a. a -> [a] -> [a]
: [UnpaddedStructField]
tail)
        go InlineSize
size [StructField]
paddedFields [UnpaddedStructField
x] =
          let size' :: InlineSize
size' = InlineSize
size InlineSize -> InlineSize -> InlineSize
forall a. Num a => a -> a -> a
+ StructFieldType -> InlineSize
structFieldTypeSize (UnpaddedStructField -> StructFieldType
unpaddedStructFieldType UnpaddedStructField
x)
              structAlignment' :: InlineSize
structAlignment' = Alignment -> InlineSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Alignment @InlineSize Alignment
structAlignment
              paddingNeeded :: InlineSize
paddingNeeded = (InlineSize
size' InlineSize -> InlineSize -> InlineSize
forall n. Integral n => n -> n -> n
`roundUpToNearestMultipleOf` InlineSize
structAlignment') InlineSize -> InlineSize -> InlineSize
forall a. Num a => a -> a -> a
- InlineSize
size'
              size'' :: InlineSize
size'' = InlineSize
size' InlineSize -> InlineSize -> InlineSize
forall a. Num a => a -> a -> a
+ InlineSize
paddingNeeded
              paddedField :: StructField
paddedField = StructField :: Ident -> Word8 -> Word16 -> StructFieldType -> StructField
StructField
                { structFieldIdent :: Ident
structFieldIdent = UnpaddedStructField -> Ident
unpaddedStructFieldIdent UnpaddedStructField
x
                -- NOTE: it is safe to narrow `paddingNeeded` to a word8 here because it's always smaller than `nextFieldsAlignment`
                , structFieldPadding :: Word8
structFieldPadding = InlineSize -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral @InlineSize @Word8 InlineSize
paddingNeeded
                , structFieldOffset :: Word16
structFieldOffset = InlineSize -> Word16
coerce InlineSize
size
                , structFieldType :: StructFieldType
structFieldType = UnpaddedStructField -> StructFieldType
unpaddedStructFieldType UnpaddedStructField
x
                }
          in  (InlineSize
size'', StructField
paddedField StructField -> [StructField] -> [StructField]
forall a. a -> [a] -> [a]
: [StructField]
paddedFields)

    validateStructField :: ST.StructField -> m UnpaddedStructField
    validateStructField :: StructField -> m UnpaddedStructField
validateStructField StructField
sf =
      StructField -> m UnpaddedStructField -> m UnpaddedStructField
forall (m :: * -> *) a b.
(MonadValidation m, HasIdent a) =>
a -> m b -> m b
validating StructField
sf (m UnpaddedStructField -> m UnpaddedStructField)
-> m UnpaddedStructField -> m UnpaddedStructField
forall a b. (a -> b) -> a -> b
$ do
        StructField -> m ()
checkUnsupportedAttributes StructField
sf
        StructField -> m ()
forall (m :: * -> *) a.
(MonadValidation m, HasMetadata a) =>
a -> m ()
checkUndeclaredAttributes StructField
sf
        StructFieldType
structFieldType <- Type -> m StructFieldType
validateStructFieldType (StructField -> Type
ST.structFieldType StructField
sf)
        UnpaddedStructField -> m UnpaddedStructField
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnpaddedStructField -> m UnpaddedStructField)
-> UnpaddedStructField -> m UnpaddedStructField
forall a b. (a -> b) -> a -> b
$ UnpaddedStructField :: Ident -> StructFieldType -> UnpaddedStructField
UnpaddedStructField
          { unpaddedStructFieldIdent :: Ident
unpaddedStructFieldIdent = StructField -> Ident
forall a. HasIdent a => a -> Ident
getIdent StructField
sf
          , unpaddedStructFieldType :: StructFieldType
unpaddedStructFieldType = StructFieldType
structFieldType
          }

    validateStructFieldType :: ST.Type -> m StructFieldType
    validateStructFieldType :: Type -> m StructFieldType
validateStructFieldType Type
structFieldType =
      case Type
structFieldType of
        Type
ST.TInt8 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SInt8
        Type
ST.TInt16 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SInt16
        Type
ST.TInt32 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SInt32
        Type
ST.TInt64 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SInt64
        Type
ST.TWord8 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SWord8
        Type
ST.TWord16 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SWord16
        Type
ST.TWord32 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SWord32
        Type
ST.TWord64 -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SWord64
        Type
ST.TFloat -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SFloat
        Type
ST.TDouble -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SDouble
        Type
ST.TBool -> StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure StructFieldType
SBool
        Type
ST.TString -> String -> m StructFieldType
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
invalidStructFieldType
        ST.TVector Type
_ -> String -> m StructFieldType
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
invalidStructFieldType
        ST.TRef TypeRef
typeRef ->
          Namespace
-> FileTree Stage2
-> TypeRef
-> m (Match EnumDecl StructDecl TableDecl UnionDecl)
forall (m :: * -> *) e s t u.
MonadValidation m =>
Namespace
-> FileTree (SymbolTable e s t u) -> TypeRef -> m (Match e s t u)
findDecl Namespace
currentNamespace FileTree Stage2
symbolTables TypeRef
typeRef m (Match EnumDecl StructDecl TableDecl UnionDecl)
-> (Match EnumDecl StructDecl TableDecl UnionDecl
    -> m StructFieldType)
-> m StructFieldType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            MatchE Namespace
enumNamespace EnumDecl
enum ->
              StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeRef -> EnumType -> StructFieldType
SEnum (Namespace -> Ident -> TypeRef
TypeRef Namespace
enumNamespace (EnumDecl -> Ident
forall a. HasIdent a => a -> Ident
getIdent EnumDecl
enum)) (EnumDecl -> EnumType
enumType EnumDecl
enum))
            MatchS Namespace
nestedNamespace StructDecl
nestedStruct -> do
              -- if this is a reference to a struct, we need to validate it first
              StructDecl
validNestedStruct <- FileTree Stage2 -> Namespace -> StructDecl -> m StructDecl
forall (m :: * -> *).
(MonadState (Map (Namespace, Ident) StructDecl) m,
 MonadValidation m) =>
FileTree Stage2 -> Namespace -> StructDecl -> m StructDecl
validateStruct FileTree Stage2
symbolTables Namespace
nestedNamespace StructDecl
nestedStruct
              StructFieldType -> m StructFieldType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StructFieldType -> m StructFieldType)
-> StructFieldType -> m StructFieldType
forall a b. (a -> b) -> a -> b
$ (Namespace, StructDecl) -> StructFieldType
SStruct (Namespace
nestedNamespace, StructDecl
validNestedStruct)
            Match EnumDecl StructDecl TableDecl UnionDecl
_ -> String -> m StructFieldType
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
invalidStructFieldType

    checkUnsupportedAttributes :: ST.StructField -> m ()
    checkUnsupportedAttributes :: StructField -> m ()
checkUnsupportedAttributes StructField
structField = do
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Metadata -> Bool
hasAttribute Text
deprecatedAttr (StructField -> Metadata
ST.structFieldMetadata StructField
structField)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> m ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"can't deprecate fields in a struct"
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Metadata -> Bool
hasAttribute Text
requiredAttr (StructField -> Metadata
ST.structFieldMetadata StructField
structField)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> m ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"struct fields are already required, the 'required' attribute is redundant"
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Metadata -> Bool
hasAttribute Text
idAttr (StructField -> Metadata
ST.structFieldMetadata StructField
structField)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> m ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg String
"struct fields cannot be reordered using the 'id' attribute"

    getForceAlignAttr :: m (Maybe Integer)
    getForceAlignAttr :: m (Maybe Integer)
getForceAlignAttr = Text -> Metadata -> m (Maybe Integer)
forall (m :: * -> *).
MonadValidation m =>
Text -> Metadata -> m (Maybe Integer)
findIntAttr Text
forceAlignAttr (StructDecl -> Metadata
ST.structMetadata StructDecl
struct)

    validateForceAlign :: Alignment -> Integer -> m Alignment
    validateForceAlign :: Alignment -> Integer -> m Alignment
validateForceAlign Alignment
naturalAlignment Integer
forceAlign =
      if Integer -> Bool
forall a. (Num a, Bits a) => a -> Bool
isPowerOfTwo Integer
forceAlign
        Bool -> Bool -> Bool
&& (Integer, Integer) -> Integer -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Alignment -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Alignment @Integer Alignment
naturalAlignment, Integer
16) Integer
forceAlign
        then Alignment -> m Alignment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Alignment
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Integer @Alignment Integer
forceAlign)
        else String -> m Alignment
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> m Alignment) -> String -> m Alignment
forall a b. (a -> b) -> a -> b
$
              String
"force_align must be a power of two integer ranging from the struct's natural alignment (in this case, "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Alignment -> String
forall a. Display a => a -> String
display Alignment
naturalAlignment
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
") to 16"

    checkDuplicateFields :: m ()
    checkDuplicateFields :: m ()
checkDuplicateFields =
      NonEmpty StructField -> m ()
forall (m :: * -> *) (f :: * -> *) a.
(MonadValidation m, Foldable f, Functor f, HasIdent a) =>
f a -> m ()
checkDuplicateIdentifiers
        (StructDecl -> NonEmpty StructField
ST.structFields StructDecl
struct)

----------------------------------
------------ Helpers -------------
----------------------------------
structFieldAlignment :: UnpaddedStructField -> Alignment
structFieldAlignment :: UnpaddedStructField -> Alignment
structFieldAlignment UnpaddedStructField
usf =
  case UnpaddedStructField -> StructFieldType
unpaddedStructFieldType UnpaddedStructField
usf of
    StructFieldType
SInt8 -> Alignment
forall a. Num a => a
int8Size
    StructFieldType
SInt16 -> Alignment
forall a. Num a => a
int16Size
    StructFieldType
SInt32 -> Alignment
forall a. Num a => a
int32Size
    StructFieldType
SInt64 -> Alignment
forall a. Num a => a
int64Size
    StructFieldType
SWord8 -> Alignment
forall a. Num a => a
word8Size
    StructFieldType
SWord16 -> Alignment
forall a. Num a => a
word16Size
    StructFieldType
SWord32 -> Alignment
forall a. Num a => a
word32Size
    StructFieldType
SWord64 -> Alignment
forall a. Num a => a
word64Size
    StructFieldType
SFloat -> Alignment
forall a. Num a => a
floatSize
    StructFieldType
SDouble -> Alignment
forall a. Num a => a
doubleSize
    StructFieldType
SBool -> Alignment
forall a. Num a => a
boolSize
    SEnum TypeRef
_ EnumType
enumType -> EnumType -> Alignment
enumAlignment EnumType
enumType
    SStruct (Namespace
_, StructDecl
nestedStruct) -> StructDecl -> Alignment
structAlignment StructDecl
nestedStruct

enumAlignment :: EnumType -> Alignment
enumAlignment :: EnumType -> Alignment
enumAlignment = Word8 -> Alignment
Alignment (Word8 -> Alignment)
-> (EnumType -> Word8) -> EnumType -> Alignment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnumType -> Word8
enumSize

-- | The size of an enum is either 1, 2, 4 or 8 bytes, so its size fits in a Word8
enumSize :: EnumType -> Word8
enumSize :: EnumType -> Word8
enumSize EnumType
e =
  case EnumType
e of
    EnumType
EInt8 -> Word8
forall a. Num a => a
int8Size
    EnumType
EInt16 -> Word8
forall a. Num a => a
int16Size
    EnumType
EInt32 -> Word8
forall a. Num a => a
int32Size
    EnumType
EInt64 -> Word8
forall a. Num a => a
int64Size
    EnumType
EWord8 -> Word8
forall a. Num a => a
word8Size
    EnumType
EWord16 -> Word8
forall a. Num a => a
word16Size
    EnumType
EWord32 -> Word8
forall a. Num a => a
word32Size
    EnumType
EWord64 -> Word8
forall a. Num a => a
word64Size

structFieldTypeSize :: StructFieldType -> InlineSize
structFieldTypeSize :: StructFieldType -> InlineSize
structFieldTypeSize StructFieldType
sft =
  case StructFieldType
sft of
    StructFieldType
SInt8 -> InlineSize
forall a. Num a => a
int8Size
    StructFieldType
SInt16 -> InlineSize
forall a. Num a => a
int16Size
    StructFieldType
SInt32 -> InlineSize
forall a. Num a => a
int32Size
    StructFieldType
SInt64 -> InlineSize
forall a. Num a => a
int64Size
    StructFieldType
SWord8 -> InlineSize
forall a. Num a => a
word8Size
    StructFieldType
SWord16 -> InlineSize
forall a. Num a => a
word16Size
    StructFieldType
SWord32 -> InlineSize
forall a. Num a => a
word32Size
    StructFieldType
SWord64 -> InlineSize
forall a. Num a => a
word64Size
    StructFieldType
SFloat -> InlineSize
forall a. Num a => a
floatSize
    StructFieldType
SDouble -> InlineSize
forall a. Num a => a
doubleSize
    StructFieldType
SBool -> InlineSize
forall a. Num a => a
boolSize
    SEnum TypeRef
_ EnumType
enumType -> Word8 -> InlineSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @InlineSize (EnumType -> Word8
enumSize EnumType
enumType)
    SStruct (Namespace
_, StructDecl
nestedStruct) -> StructDecl -> InlineSize
structSize StructDecl
nestedStruct

checkDuplicateIdentifiers :: (MonadValidation m, Foldable f, Functor f, HasIdent a) => f a -> m ()
checkDuplicateIdentifiers :: f a -> m ()
checkDuplicateIdentifiers f a
xs =
  case f Ident -> [Ident]
forall (f :: * -> *) a.
(Foldable f, Functor f, Ord a) =>
f a -> [a]
findDups (a -> Ident
forall a. HasIdent a => a -> Ident
getIdent (a -> Ident) -> f a -> f Ident
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
xs) of
    [] -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Ident]
dups ->
      String -> m ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        [Ident] -> String
forall a. Display a => a -> String
display [Ident]
dups String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" declared more than once"
  where
    findDups :: (Foldable f, Functor f, Ord a) => f a -> [a]
    findDups :: f a -> [a]
findDups f a
xs = Map a (Sum Int) -> [a]
forall k a. Map k a -> [k]
Map.keys (Map a (Sum Int) -> [a]) -> Map a (Sum Int) -> [a]
forall a b. (a -> b) -> a -> b
$ (Sum Int -> Bool) -> Map a (Sum Int) -> Map a (Sum Int)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Sum Int -> Sum Int -> Bool
forall a. Ord a => a -> a -> Bool
>Sum Int
1) (Map a (Sum Int) -> Map a (Sum Int))
-> Map a (Sum Int) -> Map a (Sum Int)
forall a b. (a -> b) -> a -> b
$ f a -> Map a (Sum Int)
forall (f :: * -> *) a.
(Foldable f, Functor f, Ord a) =>
f a -> Map a (Sum Int)
occurrences f a
xs

    occurrences :: (Foldable f, Functor f, Ord a) => f a -> Map a (Sum Int)
    occurrences :: f a -> Map a (Sum Int)
occurrences f a
xs =
      (Sum Int -> Sum Int -> Sum Int)
-> [Map a (Sum Int)] -> Map a (Sum Int)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Sum Int -> Sum Int -> Sum Int
forall a. Semigroup a => a -> a -> a
(<>) ([Map a (Sum Int)] -> Map a (Sum Int))
-> [Map a (Sum Int)] -> Map a (Sum Int)
forall a b. (a -> b) -> a -> b
$ f (Map a (Sum Int)) -> [Map a (Sum Int)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (f (Map a (Sum Int)) -> [Map a (Sum Int)])
-> f (Map a (Sum Int)) -> [Map a (Sum Int)]
forall a b. (a -> b) -> a -> b
$ (a -> Map a (Sum Int)) -> f a -> f (Map a (Sum Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
x -> a -> Sum Int -> Map a (Sum Int)
forall k a. k -> a -> Map k a
Map.singleton a
x (Int -> Sum Int
forall a. a -> Sum a
Sum Int
1)) f a
xs

checkUndeclaredAttributes :: (MonadValidation m, HasMetadata a) => a -> m ()
checkUndeclaredAttributes :: a -> m ()
checkUndeclaredAttributes a
a = do
  Set AttributeDecl
allAttributes <- m (Set AttributeDecl)
forall (m :: * -> *). MonadValidation m => m (Set AttributeDecl)
getDeclaredAttributes
  [Text] -> (Text -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text (Maybe AttributeVal) -> [Text]
forall k a. Map k a -> [k]
Map.keys (Map Text (Maybe AttributeVal) -> [Text])
-> (a -> Map Text (Maybe AttributeVal)) -> a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadata -> Map Text (Maybe AttributeVal)
ST.unMetadata (Metadata -> Map Text (Maybe AttributeVal))
-> (a -> Metadata) -> a -> Map Text (Maybe AttributeVal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Metadata
forall a. HasMetadata a => a -> Metadata
getMetadata (a -> [Text]) -> a -> [Text]
forall a b. (a -> b) -> a -> b
$ a
a) ((Text -> m ()) -> m ()) -> (Text -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Text
attr ->
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> AttributeDecl
coerce Text
attr AttributeDecl -> Set AttributeDecl -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set AttributeDecl
allAttributes) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      String -> m ()
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"user defined attributes must be declared before use: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display Text
attr

hasAttribute :: Text -> ST.Metadata -> Bool
hasAttribute :: Text -> Metadata -> Bool
hasAttribute Text
name (ST.Metadata Map Text (Maybe AttributeVal)
attrs) = Text -> Map Text (Maybe AttributeVal) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
name Map Text (Maybe AttributeVal)
attrs

findIntAttr :: MonadValidation m => Text -> ST.Metadata -> m (Maybe Integer)
findIntAttr :: Text -> Metadata -> m (Maybe Integer)
findIntAttr Text
name (ST.Metadata Map Text (Maybe AttributeVal)
attrs) =
  case Text -> Map Text (Maybe AttributeVal) -> Maybe (Maybe AttributeVal)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text (Maybe AttributeVal)
attrs of
    Maybe (Maybe AttributeVal)
Nothing                  -> Maybe Integer -> m (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
    Just Maybe AttributeVal
Nothing             -> m (Maybe Integer)
forall a. m a
err
    Just (Just (ST.AttrI Integer
i)) -> Maybe Integer -> m (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i)
    Just (Just (ST.AttrS Text
t)) ->
      case String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe @Integer (Text -> String
T.unpack Text
t) of
        Just Integer
i  -> Maybe Integer -> m (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
i)
        Maybe Integer
Nothing -> m (Maybe Integer)
forall a. m a
err
  where
    err :: m a
err =
      String -> m a
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$
        String
"expected attribute '"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display Text
name
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' to have an integer value, e.g. '"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display Text
name
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": 123'"

findStringAttr :: Text -> ST.Metadata -> Validation (Maybe Text)
findStringAttr :: Text -> Metadata -> Validation (Maybe Text)
findStringAttr Text
name (ST.Metadata Map Text (Maybe AttributeVal)
attrs) =
  case Text -> Map Text (Maybe AttributeVal) -> Maybe (Maybe AttributeVal)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text (Maybe AttributeVal)
attrs of
    Maybe (Maybe AttributeVal)
Nothing                  -> Maybe Text -> Validation (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
    Just (Just (ST.AttrS Text
s)) -> Maybe Text -> Validation (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s)
    Just Maybe AttributeVal
_ ->
      String -> Validation (Maybe Text)
forall (m :: * -> *) a. MonadValidation m => String -> m a
throwErrorMsg (String -> Validation (Maybe Text))
-> String -> Validation (Maybe Text)
forall a b. (a -> b) -> a -> b
$
        String
"expected attribute '"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display Text
name
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' to have a string value, e.g. '"
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Display a => a -> String
display Text
name
        String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": \"abc\"'"

isPowerOfTwo :: (Num a, Bits a) => a -> Bool
isPowerOfTwo :: a -> Bool
isPowerOfTwo a
0 = Bool
False
isPowerOfTwo a
n = (a
n a -> a -> a
forall a. Bits a => a -> a -> a
.&. (a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
1)) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0

roundUpToNearestMultipleOf :: Integral n => n -> n -> n
roundUpToNearestMultipleOf :: n -> n -> n
roundUpToNearestMultipleOf n
x n
y =
  case n
x n -> n -> n
forall n. Integral n => n -> n -> n
`rem` n
y of
    n
0         -> n
x
    n
remainder -> (n
y n -> n -> n
forall a. Num a => a -> a -> a
- n
remainder) n -> n -> n
forall a. Num a => a -> a -> a
+ n
x