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

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


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)


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
    | BuiltinType StdType
    | ExternalType (Lexeme Text)
    | Array (Maybe TypeInfo) [TypeInfo]

    | Var (Lexeme Text) 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
    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


lookupType :: Text -> TypeSystem -> Maybe TypeDescr
lookupType :: Text -> TypeSystem -> Maybe TypeDescr
lookupType = Text -> TypeSystem -> Maybe TypeDescr
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Text -> TypeSystem -> Maybe TypeDescr)
-> (Text -> Text) -> Text -> TypeSystem -> Maybe TypeDescr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.toLower

insert :: Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert :: Lexeme Text -> TypeDescr -> State TypeSystem [TypeInfo]
insert Lexeme Text
name TypeDescr
ty = 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 -> 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) TypeDescr
ty
    [TypeInfo] -> State TypeSystem [TypeInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []

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)
s(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 (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)
s(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 ((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

    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]
    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

    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 TypeInfo -> TypeInfo
resolveRef) [(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 TypeInfo -> TypeInfo
resolveRef) [(Lexeme Text, TypeInfo)]
mems)
    go ty :: TypeDescr
ty@EnumDescr{}         = TypeDescr
ty
    go ty :: TypeDescr
ty@IntDescr{}          = TypeDescr
ty

    resolveRef :: TypeInfo -> TypeInfo
resolveRef 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
    resolveRef (Const   TypeInfo
ty)           = TypeInfo -> TypeInfo
Const   (TypeInfo -> TypeInfo
resolveRef TypeInfo
ty)
    resolveRef (Pointer TypeInfo
ty)           = TypeInfo -> TypeInfo
Pointer (TypeInfo -> TypeInfo
resolveRef TypeInfo
ty)
    resolveRef (Sized TypeInfo
ty Lexeme Text
size)        = TypeInfo -> Lexeme Text -> TypeInfo
Sized (TypeInfo -> TypeInfo
resolveRef TypeInfo
ty) Lexeme Text
size
    resolveRef (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
$ TypeInfo -> TypeInfo
resolveRef TypeInfo
ty) [TypeInfo]
dims
    resolveRef TypeInfo
ty = TypeInfo
ty