{-# OPTIONS_GHC -Wwarn #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData        #-}
module Tokstyle.Common.TypeSystem where

import           Control.Arrow              (second)
import           Control.Monad              (forM_)
import           Control.Monad.State.Strict (State)
import qualified Control.Monad.State.Strict as State
import           Data.Fix                   (Fix (..), foldFixM)
import           Data.Map.Strict            (Map)
import qualified Data.Map.Strict            as Map
import           Data.Set                   (Set)
import qualified Data.Set                   as Set
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import qualified Debug.Trace                as Debug
import           Language.Cimple            (Lexeme (..), LiteralType (..),
                                             Node, NodeF (..), lexemeText)
import qualified Language.Cimple            as C


debugging :: Bool
debugging :: Bool
debugging = Bool
False

dtrace :: String -> a -> a
dtrace :: String -> a -> a
dtrace String
msg = if Bool
debugging then String -> a -> a
forall a. String -> a -> a
Debug.trace String
msg else a -> a
forall a. a -> a
id


data StdType
    = VoidTy
    | BoolTy
    | CharTy
    | U08Ty
    | S08Ty
    | U16Ty
    | S16Ty
    | U32Ty
    | S32Ty
    | U64Ty
    | S64Ty
    | SizeTy
    | F32Ty
    | F64Ty
    deriving (Int -> StdType -> ShowS
[StdType] -> ShowS
StdType -> String
(Int -> StdType -> ShowS)
-> (StdType -> String) -> ([StdType] -> ShowS) -> Show StdType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StdType] -> ShowS
$cshowList :: [StdType] -> ShowS
show :: StdType -> String
$cshow :: StdType -> String
showsPrec :: Int -> StdType -> ShowS
$cshowsPrec :: Int -> StdType -> ShowS
Show, StdType -> StdType -> Bool
(StdType -> StdType -> Bool)
-> (StdType -> StdType -> Bool) -> Eq StdType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StdType -> StdType -> Bool
$c/= :: StdType -> StdType -> Bool
== :: StdType -> StdType -> Bool
$c== :: StdType -> StdType -> Bool
Eq, Eq StdType
Eq StdType
-> (StdType -> StdType -> Ordering)
-> (StdType -> StdType -> Bool)
-> (StdType -> StdType -> Bool)
-> (StdType -> StdType -> Bool)
-> (StdType -> StdType -> Bool)
-> (StdType -> StdType -> StdType)
-> (StdType -> StdType -> StdType)
-> Ord StdType
StdType -> StdType -> Bool
StdType -> StdType -> Ordering
StdType -> StdType -> StdType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: StdType -> StdType -> StdType
$cmin :: StdType -> StdType -> StdType
max :: StdType -> StdType -> StdType
$cmax :: StdType -> StdType -> StdType
>= :: StdType -> StdType -> Bool
$c>= :: StdType -> StdType -> Bool
> :: StdType -> StdType -> Bool
$c> :: StdType -> StdType -> Bool
<= :: StdType -> StdType -> Bool
$c<= :: StdType -> StdType -> Bool
< :: StdType -> StdType -> Bool
$c< :: StdType -> StdType -> Bool
compare :: StdType -> StdType -> Ordering
$ccompare :: StdType -> StdType -> Ordering
$cp1Ord :: Eq StdType
Ord)


data TypeRef
    = UnresolvedRef
    | StructRef
    | UnionRef
    | EnumRef
    | IntRef
    | FuncRef
    deriving (Int -> TypeRef -> ShowS
[TypeRef] -> ShowS
TypeRef -> String
(Int -> TypeRef -> ShowS)
-> (TypeRef -> String) -> ([TypeRef] -> ShowS) -> Show TypeRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeRef] -> ShowS
$cshowList :: [TypeRef] -> ShowS
show :: TypeRef -> String
$cshow :: TypeRef -> String
showsPrec :: Int -> TypeRef -> ShowS
$cshowsPrec :: Int -> TypeRef -> ShowS
Show)


data TypeInfo
    = TypeRef TypeRef (Lexeme Text)

    | Pointer TypeInfo
    | Sized TypeInfo (Lexeme Text)
    | Const TypeInfo
    | Owner TypeInfo
    | Nonnull TypeInfo
    | Nullable TypeInfo
    | BuiltinType StdType
    | ExternalType (Lexeme Text)
    | Array (Maybe TypeInfo) [TypeInfo]

    | Var (Lexeme Text) TypeInfo
    | Function TypeInfo [TypeInfo]
    | IntLit (Lexeme Text)
    | NameLit (Lexeme Text)
    | EnumMem (Lexeme Text)
    deriving (Int -> TypeInfo -> ShowS
[TypeInfo] -> ShowS
TypeInfo -> String
(Int -> TypeInfo -> ShowS)
-> (TypeInfo -> String) -> ([TypeInfo] -> ShowS) -> Show TypeInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeInfo] -> ShowS
$cshowList :: [TypeInfo] -> ShowS
show :: TypeInfo -> String
$cshow :: TypeInfo -> String
showsPrec :: Int -> TypeInfo -> ShowS
$cshowsPrec :: Int -> TypeInfo -> ShowS
Show)


data TypeDescr
    = StructDescr (Lexeme Text) [(Lexeme Text, TypeInfo)]
    | UnionDescr (Lexeme Text) [(Lexeme Text, TypeInfo)]
    | EnumDescr (Lexeme Text) [TypeInfo]
    | IntDescr (Lexeme Text) StdType
    | FuncDescr (Lexeme Text) TypeInfo [TypeInfo]
    | AliasDescr (Lexeme Text) TypeInfo
    deriving (Int -> TypeDescr -> ShowS
[TypeDescr] -> ShowS
TypeDescr -> String
(Int -> TypeDescr -> ShowS)
-> (TypeDescr -> String)
-> ([TypeDescr] -> ShowS)
-> Show TypeDescr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypeDescr] -> ShowS
$cshowList :: [TypeDescr] -> ShowS
show :: TypeDescr -> String
$cshow :: TypeDescr -> String
showsPrec :: Int -> TypeDescr -> ShowS
$cshowsPrec :: Int -> TypeDescr -> ShowS
Show)


type TypeSystem = Map Text TypeDescr


getTypeRefName :: TypeInfo -> Maybe Text
getTypeRefName :: TypeInfo -> Maybe Text
getTypeRefName = \case
    TypeRef TypeRef
_ (L AlexPosn
_ LexemeClass
_ Text
name) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name
    Pointer TypeInfo
t              -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
t
    Const TypeInfo
t                -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
t
    Owner TypeInfo
t                -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
t
    Nonnull TypeInfo
t              -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
t
    Nullable TypeInfo
t             -> TypeInfo -> Maybe Text
getTypeRefName TypeInfo
t
    TypeInfo
_                      -> Maybe Text
forall a. Maybe a
Nothing


lookupType :: Text -> TypeSystem -> Maybe TypeDescr
lookupType :: Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
name TypeSystem
ts = Set Text -> Text -> Maybe TypeDescr
go Set Text
forall a. Set a
Set.empty Text
name
  where
    go :: Set Text -> Text -> Maybe TypeDescr
go Set Text
visited Text
n
        | Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Text -> Text
Text.toLower Text
n) Set Text
visited = Maybe TypeDescr
forall a. Maybe a
Nothing
        | Bool
otherwise =
            let res :: Maybe TypeDescr
res = case Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> Text
Text.toLower Text
n) TypeSystem
ts of
                    Just (AliasDescr Lexeme Text
_ TypeInfo
target) ->
                        case TypeInfo -> Maybe Text
getTypeRefName TypeInfo
target of
                            Just Text
next -> Set Text -> Text -> Maybe TypeDescr
go (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert (Text -> Text
Text.toLower Text
n) Set Text
visited) Text
next
                            Maybe Text
Nothing   -> case TypeInfo
target of
                                TypeRef TypeRef
StructRef (L AlexPosn
_ LexemeClass
_ Text
"") -> Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"" TypeSystem
ts
                                TypeRef TypeRef
UnionRef  (L AlexPosn
_ LexemeClass
_ Text
"") -> Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"" TypeSystem
ts
                                TypeInfo
_ -> TypeDescr -> Maybe TypeDescr
forall a. a -> Maybe a
Just (Lexeme Text -> TypeInfo -> TypeDescr
AliasDescr (AlexPosn -> LexemeClass -> Text -> Lexeme Text
forall text. AlexPosn -> LexemeClass -> text -> Lexeme text
L (Int -> Int -> Int -> AlexPosn
C.AlexPn Int
0 Int
0 Int
0) LexemeClass
C.IdVar Text
n) TypeInfo
target)
                    Maybe TypeDescr
r -> Maybe TypeDescr
r
            in String -> Maybe TypeDescr -> Maybe TypeDescr
forall a. String -> a -> a
dtrace (String
"lookupType: name=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" res=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe TypeDescr -> String
forall a. Show a => a -> String
show Maybe TypeDescr
res) Maybe TypeDescr
res

insert :: Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert :: Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert Lexeme Text
name TypeDescr
ty = do
    let nameText :: Text
nameText = Text -> Text
Text.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name
    Maybe TypeDescr
existing <- (TypeSystem -> Maybe TypeDescr)
-> StateT TypeSystem Identity (Maybe TypeDescr)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
State.gets (Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
nameText)
    case (TypeDescr
ty, Maybe TypeDescr
existing) of
        (AliasDescr Lexeme Text
_ (TypeRef TypeRef
_ (L AlexPosn
_ LexemeClass
_ Text
target)), Just StructDescr{}) | Text -> Text
Text.toLower Text
target Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nameText ->
            [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnresolvedRef Lexeme Text
name]
        (AliasDescr Lexeme Text
_ (TypeRef TypeRef
_ (L AlexPosn
_ LexemeClass
_ Text
target)), Just UnionDescr{})  | Text -> Text
Text.toLower Text
target Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nameText ->
            [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnresolvedRef Lexeme Text
name]
        (AliasDescr Lexeme Text
_ (TypeRef TypeRef
_ (L AlexPosn
_ LexemeClass
_ Text
target)), Just EnumDescr{})   | Text -> Text
Text.toLower Text
target Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
nameText ->
            [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnresolvedRef Lexeme Text
name]
        (TypeDescr, Maybe TypeDescr)
_ -> do
            (TypeSystem -> TypeSystem) -> StateT TypeSystem Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((TypeSystem -> TypeSystem) -> StateT TypeSystem Identity ())
-> (TypeSystem -> TypeSystem) -> StateT TypeSystem Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> TypeDescr -> TypeSystem -> TypeSystem
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
nameText TypeDescr
ty
            [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnresolvedRef Lexeme Text
name]

foldArray :: Lexeme Text -> [[TypeInfo]] -> TypeInfo -> TypeInfo
foldArray :: Lexeme Text -> [[TypeInfo]] -> TypeInfo -> TypeInfo
foldArray Lexeme Text
name [[TypeInfo]]
arrs TypeInfo
baseTy = Lexeme Text -> TypeInfo -> TypeInfo
Var Lexeme Text
name (TypeInfo -> [TypeInfo] -> TypeInfo
merge TypeInfo
baseTy ([[TypeInfo]] -> [TypeInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TypeInfo]]
arrs))
  where
    merge :: TypeInfo -> [TypeInfo] -> TypeInfo
merge TypeInfo
ty (Array Maybe TypeInfo
Nothing [TypeInfo]
dims:[TypeInfo]
xs) = TypeInfo -> [TypeInfo] -> TypeInfo
merge (Maybe TypeInfo -> [TypeInfo] -> TypeInfo
Array (TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just TypeInfo
ty) [TypeInfo]
dims) [TypeInfo]
xs
    merge TypeInfo
ty []                      = TypeInfo
ty
    merge TypeInfo
ty [TypeInfo]
xs                      = String -> TypeInfo
forall a. HasCallStack => String -> a
error ((TypeInfo, [TypeInfo]) -> String
forall a. Show a => a -> String
show (TypeInfo
ty, [TypeInfo]
xs))


vars :: [[TypeInfo]] -> [(Lexeme Text, TypeInfo)]
vars :: [[TypeInfo]] -> [(Lexeme Text, TypeInfo)]
vars = [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer ([(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)])
-> ([[TypeInfo]] -> [(Lexeme Text, TypeInfo)])
-> [[TypeInfo]]
-> [(Lexeme Text, TypeInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeInfo -> (Lexeme Text, TypeInfo))
-> [TypeInfo] -> [(Lexeme Text, TypeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> (Lexeme Text, TypeInfo)
go ([TypeInfo] -> [(Lexeme Text, TypeInfo)])
-> ([[TypeInfo]] -> [TypeInfo])
-> [[TypeInfo]]
-> [(Lexeme Text, TypeInfo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TypeInfo]] -> [TypeInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  where
    go :: TypeInfo -> (Lexeme Text, TypeInfo)
go (Var Lexeme Text
name TypeInfo
ty) = (Lexeme Text
name, TypeInfo
ty)
    go TypeInfo
x             = String -> (Lexeme Text, TypeInfo)
forall a. HasCallStack => String -> a
error (String -> (Lexeme Text, TypeInfo))
-> String -> (Lexeme Text, TypeInfo)
forall a b. (a -> b) -> a -> b
$ TypeInfo -> String
forall a. Show a => a -> String
show TypeInfo
x

    joinSizer :: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer (d :: (Lexeme Text, TypeInfo)
d@(dn :: Lexeme Text
dn@(L AlexPosn
_ LexemeClass
_ Text
dname), dty :: TypeInfo
dty@Array{}):s :: (Lexeme Text, TypeInfo)
s@(sn :: Lexeme Text
sn@(L AlexPosn
_ LexemeClass
_ Text
sname), BuiltinType StdType
U32Ty):[(Lexeme Text, TypeInfo)]
xs)
        | Text
sname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_length", Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_size"] =
            (Lexeme Text
dn, TypeInfo -> Lexeme Text -> TypeInfo
Sized TypeInfo
dty Lexeme Text
sn) (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer [(Lexeme Text, TypeInfo)]
xs
        | Bool
otherwise = (Lexeme Text, TypeInfo)
d (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer ((Lexeme Text, TypeInfo)
s(Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
:[(Lexeme Text, TypeInfo)]
xs)
    joinSizer (d :: (Lexeme Text, TypeInfo)
d@(dn :: Lexeme Text
dn@(L AlexPosn
_ LexemeClass
_ Text
dname), dty :: TypeInfo
dty@Pointer{}):s :: (Lexeme Text, TypeInfo)
s@(sn :: Lexeme Text
sn@(L AlexPosn
_ LexemeClass
_ Text
sname), BuiltinType StdType
U32Ty):[(Lexeme Text, TypeInfo)]
xs)
        | Text
sname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_length", Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_size"] =
            (Lexeme Text
dn, TypeInfo -> Lexeme Text -> TypeInfo
Sized TypeInfo
dty Lexeme Text
sn) (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer [(Lexeme Text, TypeInfo)]
xs
        | Bool
otherwise = (Lexeme Text, TypeInfo)
d (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer ((Lexeme Text, TypeInfo)
s(Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
:[(Lexeme Text, TypeInfo)]
xs)
    joinSizer (d :: (Lexeme Text, TypeInfo)
d@(dn :: Lexeme Text
dn@(L AlexPosn
_ LexemeClass
_ Text
dname), dty :: TypeInfo
dty@(Owner Pointer{})):s :: (Lexeme Text, TypeInfo)
s@(sn :: Lexeme Text
sn@(L AlexPosn
_ LexemeClass
_ Text
sname), BuiltinType StdType
U32Ty):[(Lexeme Text, TypeInfo)]
xs)
        | Text
sname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_length", Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_size"] =
            (Lexeme Text
dn, TypeInfo -> Lexeme Text -> TypeInfo
Sized TypeInfo
dty Lexeme Text
sn) (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer [(Lexeme Text, TypeInfo)]
xs
        | Bool
otherwise = (Lexeme Text, TypeInfo)
d (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer ((Lexeme Text, TypeInfo)
s(Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
:[(Lexeme Text, TypeInfo)]
xs)
    joinSizer (d :: (Lexeme Text, TypeInfo)
d@(dn :: Lexeme Text
dn@(L AlexPosn
_ LexemeClass
_ Text
dname), dty :: TypeInfo
dty@(Nonnull Pointer{})):s :: (Lexeme Text, TypeInfo)
s@(sn :: Lexeme Text
sn@(L AlexPosn
_ LexemeClass
_ Text
sname), BuiltinType StdType
U32Ty):[(Lexeme Text, TypeInfo)]
xs)
        | Text
sname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_length", Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_size"] =
            (Lexeme Text
dn, TypeInfo -> Lexeme Text -> TypeInfo
Sized TypeInfo
dty Lexeme Text
sn) (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer [(Lexeme Text, TypeInfo)]
xs
        | Bool
otherwise = (Lexeme Text, TypeInfo)
d (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer ((Lexeme Text, TypeInfo)
s(Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
:[(Lexeme Text, TypeInfo)]
xs)
    joinSizer (d :: (Lexeme Text, TypeInfo)
d@(dn :: Lexeme Text
dn@(L AlexPosn
_ LexemeClass
_ Text
dname), dty :: TypeInfo
dty@(Nullable Pointer{})):s :: (Lexeme Text, TypeInfo)
s@(sn :: Lexeme Text
sn@(L AlexPosn
_ LexemeClass
_ Text
sname), BuiltinType StdType
U32Ty):[(Lexeme Text, TypeInfo)]
xs)
        | Text
sname Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_length", Text
dname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_size"] =
            (Lexeme Text
dn, TypeInfo -> Lexeme Text -> TypeInfo
Sized TypeInfo
dty Lexeme Text
sn) (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer [(Lexeme Text, TypeInfo)]
xs
        | Bool
otherwise = (Lexeme Text, TypeInfo)
d (Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
: [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer ((Lexeme Text, TypeInfo)
s(Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
:[(Lexeme Text, TypeInfo)]
xs)
    joinSizer ((Lexeme Text, TypeInfo)
x:[(Lexeme Text, TypeInfo)]
xs) = (Lexeme Text, TypeInfo)
x(Lexeme Text, TypeInfo)
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a. a -> [a] -> [a]
:[(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
joinSizer [(Lexeme Text, TypeInfo)]
xs
    joinSizer []     = []


builtin :: Lexeme Text -> TypeInfo
builtin :: Lexeme Text -> TypeInfo
builtin (L AlexPosn
_ LexemeClass
_              Text
"char")  = StdType -> TypeInfo
BuiltinType StdType
CharTy
builtin (L AlexPosn
_ LexemeClass
_           Text
"uint8_t")  = StdType -> TypeInfo
BuiltinType StdType
U08Ty
builtin (L AlexPosn
_ LexemeClass
_            Text
"int8_t")  = StdType -> TypeInfo
BuiltinType StdType
S08Ty
builtin (L AlexPosn
_ LexemeClass
_          Text
"uint16_t")  = StdType -> TypeInfo
BuiltinType StdType
U16Ty
builtin (L AlexPosn
_ LexemeClass
_           Text
"int16_t")  = StdType -> TypeInfo
BuiltinType StdType
S16Ty
builtin (L AlexPosn
_ LexemeClass
_          Text
"uint32_t")  = StdType -> TypeInfo
BuiltinType StdType
U32Ty
builtin (L AlexPosn
_ LexemeClass
_           Text
"int32_t")  = StdType -> TypeInfo
BuiltinType StdType
S32Ty
builtin (L AlexPosn
_ LexemeClass
_          Text
"uint64_t")  = StdType -> TypeInfo
BuiltinType StdType
U64Ty
builtin (L AlexPosn
_ LexemeClass
_           Text
"int64_t")  = StdType -> TypeInfo
BuiltinType StdType
S64Ty
builtin (L AlexPosn
_ LexemeClass
_            Text
"size_t")  = StdType -> TypeInfo
BuiltinType StdType
SizeTy
builtin (L AlexPosn
_ LexemeClass
_              Text
"void")  = StdType -> TypeInfo
BuiltinType StdType
VoidTy
builtin (L AlexPosn
_ LexemeClass
_              Text
"bool")  = StdType -> TypeInfo
BuiltinType StdType
BoolTy
builtin (L AlexPosn
_ LexemeClass
_             Text
"float")  = StdType -> TypeInfo
BuiltinType StdType
F32Ty
builtin (L AlexPosn
_ LexemeClass
_            Text
"double")  = StdType -> TypeInfo
BuiltinType StdType
F64Ty

builtin (L AlexPosn
_ LexemeClass
_               Text
"int")  = StdType -> TypeInfo
BuiltinType StdType
S32Ty
builtin (L AlexPosn
_ LexemeClass
_      Text
"unsigned int")  = StdType -> TypeInfo
BuiltinType StdType
U32Ty
builtin (L AlexPosn
_ LexemeClass
_          Text
"unsigned")  = StdType -> TypeInfo
BuiltinType StdType
U32Ty
builtin (L AlexPosn
_ LexemeClass
_   Text
"long signed int")  = StdType -> TypeInfo
BuiltinType StdType
S64Ty
builtin (L AlexPosn
_ LexemeClass
_ Text
"long unsigned int")  = StdType -> TypeInfo
BuiltinType StdType
U64Ty

builtin n :: Lexeme Text
n@(L AlexPosn
_ LexemeClass
_ Text
"OpusEncoder")      = Lexeme Text -> TypeInfo
ExternalType Lexeme Text
n
builtin n :: Lexeme Text
n@(L AlexPosn
_ LexemeClass
_ Text
"OpusDecoder")      = Lexeme Text -> TypeInfo
ExternalType Lexeme Text
n
builtin n :: Lexeme Text
n@(L AlexPosn
_ LexemeClass
_ Text
"cmp_ctx_t")        = Lexeme Text -> TypeInfo
ExternalType Lexeme Text
n
builtin n :: Lexeme Text
n@(L AlexPosn
_ LexemeClass
_ Text
"pthread_mutex_t")  = Lexeme Text -> TypeInfo
ExternalType Lexeme Text
n
builtin n :: Lexeme Text
n@(L AlexPosn
_ LexemeClass
_ Text
"pthread_rwlock_t") = Lexeme Text -> TypeInfo
ExternalType Lexeme Text
n
builtin n :: Lexeme Text
n@(L AlexPosn
_ LexemeClass
_ Text
"vpx_codec_ctx_t")  = Lexeme Text -> TypeInfo
ExternalType Lexeme Text
n

builtin Lexeme Text
name                         = TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnresolvedRef Lexeme Text
name


collectTypes :: NodeF (Lexeme Text) [TypeInfo] -> State TypeSystem [TypeInfo]
collectTypes :: NodeF (Lexeme Text) [TypeInfo] -> State TypeSystem [TypeInfo]
collectTypes NodeF (Lexeme Text) [TypeInfo]
node = case NodeF (Lexeme Text) [TypeInfo]
node of
    LiteralExpr LiteralType
ConstId Lexeme Text
name     -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lexeme Text -> TypeInfo
NameLit Lexeme Text
name]
    LiteralExpr LiteralType
Int Lexeme Text
lit          -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lexeme Text -> TypeInfo
IntLit Lexeme Text
lit]

    DeclSpecArray Maybe [TypeInfo]
Nothing        -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    DeclSpecArray (Just [TypeInfo]
arr)     -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe TypeInfo -> [TypeInfo] -> TypeInfo
Array Maybe TypeInfo
forall a. Maybe a
Nothing [TypeInfo]
arr]
    CallbackDecl Lexeme Text
ty Lexeme Text
name         -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lexeme Text -> TypeInfo -> TypeInfo
Var Lexeme Text
name (TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
FuncRef Lexeme Text
ty)]
    VarDecl [TypeInfo]
ty Lexeme Text
name []           -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text -> TypeInfo -> TypeInfo
Var Lexeme Text
name) [TypeInfo]
ty
    VarDecl [TypeInfo]
ty Lexeme Text
name [[TypeInfo]]
arrs         -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map (Lexeme Text -> [[TypeInfo]] -> TypeInfo -> TypeInfo
foldArray Lexeme Text
name [[TypeInfo]]
arrs) [TypeInfo]
ty
    MemberDecl [TypeInfo]
l Maybe (Lexeme Text)
_               -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInfo]
l
    Struct Lexeme Text
dcl [[TypeInfo]]
mems              -> (Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr)
-> Lexeme Text -> [[TypeInfo]] -> State TypeSystem [TypeInfo]
aggregate Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr
StructDescr Lexeme Text
dcl [[TypeInfo]]
mems
    Union  Lexeme Text
dcl [[TypeInfo]]
mems              -> (Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr)
-> Lexeme Text -> [[TypeInfo]] -> State TypeSystem [TypeInfo]
aggregate Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr
UnionDescr  Lexeme Text
dcl [[TypeInfo]]
mems

    Enumerator Lexeme Text
name Maybe [TypeInfo]
_            -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lexeme Text -> TypeInfo
EnumMem Lexeme Text
name]
    EnumConsts (Just Lexeme Text
dcl) [[TypeInfo]]
mems   -> Lexeme Text -> [[TypeInfo]] -> State TypeSystem [TypeInfo]
forall (t :: * -> *).
Foldable t =>
Lexeme Text -> t [TypeInfo] -> State TypeSystem [TypeInfo]
enum Lexeme Text
dcl [[TypeInfo]]
mems
    EnumDecl Lexeme Text
dcl [[TypeInfo]]
mems Lexeme Text
_          -> Lexeme Text -> [[TypeInfo]] -> State TypeSystem [TypeInfo]
forall (t :: * -> *).
Foldable t =>
Lexeme Text -> t [TypeInfo] -> State TypeSystem [TypeInfo]
enum Lexeme Text
dcl [[TypeInfo]]
mems
    Typedef [BuiltinType StdType
ty] Lexeme Text
dcl -> Lexeme Text -> StdType -> State TypeSystem [TypeInfo]
int Lexeme Text
dcl StdType
ty
    Typedef [TypeInfo
ty] Lexeme Text
dcl             -> Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert Lexeme Text
dcl (Lexeme Text -> TypeInfo -> TypeDescr
AliasDescr Lexeme Text
dcl TypeInfo
ty)

    FunctionPrototype [TypeInfo]
ty Lexeme Text
name [[TypeInfo]]
params -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lexeme Text -> TypeInfo -> TypeInfo
Var Lexeme Text
name (TypeInfo -> [TypeInfo] -> TypeInfo
Function TypeInfo
t ([[TypeInfo]] -> [TypeInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[TypeInfo]]
params)) | TypeInfo
t <- [TypeInfo]
ty]
    TypedefFunction [TypeInfo]
a -> do
        [TypeInfo]
-> (TypeInfo -> StateT TypeSystem Identity ())
-> StateT TypeSystem Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TypeInfo]
a ((TypeInfo -> StateT TypeSystem Identity ())
 -> StateT TypeSystem Identity ())
-> (TypeInfo -> StateT TypeSystem Identity ())
-> StateT TypeSystem Identity ()
forall a b. (a -> b) -> a -> b
$ \case
            Var Lexeme Text
name (Function TypeInfo
ret [TypeInfo]
params) ->
                (TypeSystem -> TypeSystem) -> StateT TypeSystem Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((TypeSystem -> TypeSystem) -> StateT TypeSystem Identity ())
-> (TypeSystem -> TypeSystem) -> StateT TypeSystem Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> TypeDescr -> TypeSystem -> TypeSystem
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Text -> Text
Text.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name) (Lexeme Text -> TypeInfo -> [TypeInfo] -> TypeDescr
FuncDescr Lexeme Text
name TypeInfo
ret [TypeInfo]
params)
            TypeInfo
_ -> () -> StateT TypeSystem Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeInfo]
a

    TyUserDefined Lexeme Text
name           -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnresolvedRef Lexeme Text
name]
    TyStruct Lexeme Text
name                -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
StructRef Lexeme Text
name]
    TyUnion Lexeme Text
name                 -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnionRef Lexeme Text
name]
    TyFunc Lexeme Text
name                  -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
FuncRef Lexeme Text
name]
    TyPointer [TypeInfo]
ns                 -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> TypeInfo
Pointer [TypeInfo]
ns
    TyConst [TypeInfo]
ns                   -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> TypeInfo
Const [TypeInfo]
ns
    TyOwner [TypeInfo]
ns                   -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> TypeInfo
Owner [TypeInfo]
ns
    TyNonnull [TypeInfo]
ns                 -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> TypeInfo
Nonnull [TypeInfo]
ns
    TyNullable [TypeInfo]
ns                -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ (TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map TypeInfo -> TypeInfo
Nullable [TypeInfo]
ns

    TyStd Lexeme Text
name                   -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return [Lexeme Text -> TypeInfo
builtin Lexeme Text
name]

    -- Throw away any type information in top-level decls that aren't
    -- defining types. The ones defining types put them into the TypeSystem
    -- map in the insertion functions below.
    ConstDecl{}                  -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    ConstDefn{}                  -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    StaticAssert{}               -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    FunctionDecl{}               -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    FunctionDefn{}               -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    PreprocDefineMacro{}         -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    EnumConsts Maybe (Lexeme Text)
Nothing [[TypeInfo]]
_         -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []

    -- The rest just collects all the types it sees.
    NodeF (Lexeme Text) [TypeInfo]
n                            -> [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([TypeInfo] -> State TypeSystem [TypeInfo])
-> [TypeInfo] -> State TypeSystem [TypeInfo]
forall a b. (a -> b) -> a -> b
$ NodeF (Lexeme Text) [TypeInfo] -> [TypeInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NodeF (Lexeme Text) [TypeInfo]
n

  where
    aggregate :: (Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr)
-> Lexeme Text -> [[TypeInfo]] -> State TypeSystem [TypeInfo]
aggregate Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr
cons Lexeme Text
dcl [[TypeInfo]]
mems = Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert Lexeme Text
dcl (Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr
cons Lexeme Text
dcl ([[TypeInfo]] -> [(Lexeme Text, TypeInfo)]
vars [[TypeInfo]]
mems))
    enum :: Lexeme Text -> t [TypeInfo] -> State TypeSystem [TypeInfo]
enum Lexeme Text
dcl t [TypeInfo]
mems = Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert Lexeme Text
dcl (Lexeme Text -> [TypeInfo] -> TypeDescr
EnumDescr Lexeme Text
dcl (t [TypeInfo] -> [TypeInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [TypeInfo]
mems))
    int :: Lexeme Text -> StdType -> State TypeSystem [TypeInfo]
int Lexeme Text
dcl StdType
ty = Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert Lexeme Text
dcl (Lexeme Text -> StdType -> TypeDescr
IntDescr Lexeme Text
dcl StdType
ty)


collect :: [(FilePath, [Node (Lexeme Text)])] -> TypeSystem
collect :: [(String, [Node (Lexeme Text)])] -> TypeSystem
collect = TypeSystem -> TypeSystem
resolve (TypeSystem -> TypeSystem)
-> ([(String, [Node (Lexeme Text)])] -> TypeSystem)
-> [(String, [Node (Lexeme Text)])]
-> TypeSystem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT TypeSystem Identity () -> TypeSystem -> TypeSystem)
-> TypeSystem -> StateT TypeSystem Identity () -> TypeSystem
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT TypeSystem Identity () -> TypeSystem -> TypeSystem
forall s a. State s a -> s -> s
State.execState TypeSystem
forall k a. Map k a
Map.empty (StateT TypeSystem Identity () -> TypeSystem)
-> ([(String, [Node (Lexeme Text)])]
    -> StateT TypeSystem Identity ())
-> [(String, [Node (Lexeme Text)])]
-> TypeSystem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, [Node (Lexeme Text)]) -> StateT TypeSystem Identity ())
-> [(String, [Node (Lexeme Text)])]
-> StateT TypeSystem Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Node (Lexeme Text) -> State TypeSystem [TypeInfo])
-> [Node (Lexeme Text)] -> StateT TypeSystem Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeF (Lexeme Text) [TypeInfo] -> State TypeSystem [TypeInfo])
-> Node (Lexeme Text) -> State TypeSystem [TypeInfo]
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM NodeF (Lexeme Text) [TypeInfo] -> State TypeSystem [TypeInfo]
collectTypes) ([Node (Lexeme Text)] -> StateT TypeSystem Identity ())
-> ((String, [Node (Lexeme Text)]) -> [Node (Lexeme Text)])
-> (String, [Node (Lexeme Text)])
-> StateT TypeSystem Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Node (Lexeme Text)]) -> [Node (Lexeme Text)]
forall a b. (a, b) -> b
snd)


resolve :: TypeSystem -> TypeSystem
resolve :: TypeSystem -> TypeSystem
resolve TypeSystem
tys = (TypeDescr -> TypeDescr) -> TypeSystem -> TypeSystem
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map TypeDescr -> TypeDescr
go TypeSystem
tys
  where
    go :: TypeDescr -> TypeDescr
go (StructDescr Lexeme Text
dcl [(Lexeme Text, TypeInfo)]
mems) = Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr
StructDescr Lexeme Text
dcl (((Lexeme Text, TypeInfo) -> (Lexeme Text, TypeInfo))
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map ((TypeInfo -> TypeInfo)
-> (Lexeme Text, TypeInfo) -> (Lexeme Text, TypeInfo)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys)) [(Lexeme Text, TypeInfo)]
mems)
    go (UnionDescr  Lexeme Text
dcl [(Lexeme Text, TypeInfo)]
mems) = Lexeme Text -> [(Lexeme Text, TypeInfo)] -> TypeDescr
UnionDescr  Lexeme Text
dcl (((Lexeme Text, TypeInfo) -> (Lexeme Text, TypeInfo))
-> [(Lexeme Text, TypeInfo)] -> [(Lexeme Text, TypeInfo)]
forall a b. (a -> b) -> [a] -> [b]
map ((TypeInfo -> TypeInfo)
-> (Lexeme Text, TypeInfo) -> (Lexeme Text, TypeInfo)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys)) [(Lexeme Text, TypeInfo)]
mems)
    go (FuncDescr Lexeme Text
dcl TypeInfo
ret [TypeInfo]
params) = Lexeme Text -> TypeInfo -> [TypeInfo] -> TypeDescr
FuncDescr Lexeme Text
dcl (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ret) ((TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys) [TypeInfo]
params)
    go (AliasDescr Lexeme Text
dcl TypeInfo
ty) = Lexeme Text -> TypeInfo -> TypeDescr
AliasDescr Lexeme Text
dcl (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty)
    go ty :: TypeDescr
ty@EnumDescr{}         = TypeDescr
ty
    go ty :: TypeDescr
ty@IntDescr{}          = TypeDescr
ty


resolveRef :: TypeSystem -> TypeInfo -> TypeInfo
resolveRef :: TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys = \case
    ty :: TypeInfo
ty@(TypeRef TypeRef
UnresolvedRef l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name)) ->
        case Text -> TypeSystem -> Maybe TypeDescr
lookupType Text
name TypeSystem
tys of
            Maybe TypeDescr
Nothing                    -> TypeInfo
ty
            Just StructDescr{}         -> TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
StructRef Lexeme Text
l
            Just UnionDescr{}          -> TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
UnionRef Lexeme Text
l
            Just EnumDescr{}           -> TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
EnumRef Lexeme Text
l
            Just IntDescr{}            -> TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
IntRef Lexeme Text
l
            Just FuncDescr{}           -> TypeRef -> Lexeme Text -> TypeInfo
TypeRef TypeRef
FuncRef Lexeme Text
l
            Just (AliasDescr Lexeme Text
_ TypeInfo
target) -> TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
target
    Const   TypeInfo
ty           -> TypeInfo -> TypeInfo
Const   (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty)
    Owner   TypeInfo
ty           -> TypeInfo -> TypeInfo
Owner   (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty)
    Nonnull TypeInfo
ty           -> TypeInfo -> TypeInfo
Nonnull (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty)
    Nullable TypeInfo
ty          -> TypeInfo -> TypeInfo
Nullable (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty)
    Pointer TypeInfo
ty           -> TypeInfo -> TypeInfo
Pointer (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty)
    Sized TypeInfo
ty Lexeme Text
size        -> TypeInfo -> Lexeme Text -> TypeInfo
Sized (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty) Lexeme Text
size
    Array (Just TypeInfo
ty) [TypeInfo]
dims -> Maybe TypeInfo -> [TypeInfo] -> TypeInfo
Array (TypeInfo -> Maybe TypeInfo
forall a. a -> Maybe a
Just (TypeInfo -> Maybe TypeInfo) -> TypeInfo -> Maybe TypeInfo
forall a b. (a -> b) -> a -> b
$ TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ty) [TypeInfo]
dims
    Function TypeInfo
ret [TypeInfo]
params  -> TypeInfo -> [TypeInfo] -> TypeInfo
Function (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys TypeInfo
ret) ((TypeInfo -> TypeInfo) -> [TypeInfo] -> [TypeInfo]
forall a b. (a -> b) -> [a] -> [b]
map (TypeSystem -> TypeInfo -> TypeInfo
resolveRef TypeSystem
tys) [TypeInfo]
params)
    TypeInfo
ty -> TypeInfo
ty