{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE TupleSections     #-}
module Tokstyle.Linter.TypeCheck (descr) where

import           Control.Monad               (foldM, void, zipWithM)
import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..), foldFixM)
import           Data.IntMap.Strict          (IntMap)
import qualified Data.IntMap.Strict          as IntMap
import           Data.Map.Strict             (Map)
import qualified Data.Map.Strict             as Map
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Debug.Trace                 (traceM)
import           GHC.Stack                   (HasCallStack)
import           Language.Cimple             (AssignOp (..), BinaryOp (..),
                                              Lexeme (..), LiteralType (..),
                                              Node, NodeF (..), UnaryOp (..))
import           Language.Cimple.Diagnostics (HasDiagnostics (..))
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import           Prettyprinter               (Pretty (..), colon, vcat, (<+>))


wantTrace :: Bool
wantTrace :: Bool
wantTrace = Bool
False

traceMaybe :: Monad m => String -> m ()
traceMaybe :: String -> m ()
traceMaybe = if Bool
wantTrace
    then String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM
    else m () -> String -> m ()
forall a b. a -> b -> a
const (m () -> String -> m ()) -> m () -> String -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


{-# ANN module ("HLint: ignore Use camelCase"::String) #-}
data Type
    -- C types
    = T_Var {-# UNPACK #-} Int
    | T_Intersect Type Type
    | T_Bot
    | T_Top
    | T_Void
    | T_Bool
    | T_Char
    | T_Int
    | T_ArrDim
    | T_Name Text
    | T_Arr Type
    | T_Ptr Type
    | T_Func Type [Type]
    | T_InitList [Type]
    | T_Struct (Map Text Type)
    | T_Add Type Type
    | T_Sub Type Type
    deriving (Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show, Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Eq Type
Eq Type
-> (Type -> Type -> Ordering)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Type)
-> (Type -> Type -> Type)
-> Ord Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
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 :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
$cp1Ord :: Eq Type
Ord)

stdTypes :: Map Text Type
stdTypes :: Map Text Type
stdTypes = [(Text, Type)] -> Map Text Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Text
"void"               , Text -> Type
T_Name Text
"void")
    , (Text
"bool"               , Type
T_Bool)
    , (Text
"char"               , Type
T_Char)
    , (Text
"float"              , Type
T_Int)
    , (Text
"double"             , Type
T_Int)
    , (Text
"size_t"             , Type
T_Int)
    , (Text
"int"                , Type
T_Int)
    , (Text
"unsigned"           , Type
T_Int)
    , (Text
"unsigned int"       , Type
T_Int)
    , (Text
"long"               , Type
T_Int)
    , (Text
"unsigned long"      , Type
T_Int)
    , (Text
"long long"          , Type
T_Int)
    , (Text
"unsigned long long" , Type
T_Int)
    , (Text
"int8_t"             , Type
T_Int)
    , (Text
"uint8_t"            , Type
T_Int)
    , (Text
"int16_t"            , Type
T_Int)
    , (Text
"uint16_t"           , Type
T_Int)
    , (Text
"int32_t"            , Type
T_Int)
    , (Text
"uint32_t"           , Type
T_Int)
    , (Text
"int64_t"            , Type
T_Int)
    , (Text
"uint64_t"           , Type
T_Int)
    ]

unionWithM :: (Monad m, Ord k) => (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM :: (a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM a -> a -> m a
f Map k a
mapA Map k a
mapB =
  Map k (m a) -> m (Map k a)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (Map k (m a) -> m (Map k a)) -> Map k (m a) -> m (Map k a)
forall a b. (a -> b) -> a -> b
$ (m a -> m a -> m a) -> Map k (m a) -> Map k (m a) -> Map k (m a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\m a
a m a
b -> do {a
x <- m a
a; a
y <- m a
b; a -> a -> m a
f a
x a
y}) ((a -> m a) -> Map k a -> Map k (m a)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Map k a
mapA) ((a -> m a) -> Map k a -> Map k (m a)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Map k a
mapB)

data Env = Env
    { Env -> [Text]
envDiags   :: [Text]
    , Env -> [Text]
envLocals  :: [Text]
    , Env -> Map Text Type
envTypes   :: Map Text Type
    , Env -> IntMap Type
envVars    :: IntMap Type
    , Env -> Int
envNextVar :: Int
    }
    deriving (Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Env] -> ShowS
$cshowList :: [Env] -> ShowS
show :: Env -> String
$cshow :: Env -> String
showsPrec :: Int -> Env -> ShowS
$cshowsPrec :: Int -> Env -> ShowS
Show)

instance HasDiagnostics Env where
    addDiagnostic :: Text -> Env -> Env
addDiagnostic Text
diag env :: Env
env@Env{[Text]
envDiags :: [Text]
envDiags :: Env -> [Text]
envDiags} = Env
env{envDiags :: [Text]
envDiags = Text -> [Text] -> [Text]
forall a. HasDiagnostics a => Text -> a -> a
addDiagnostic Text
diag [Text]
envDiags}

instance Pretty Env where
    pretty :: Env -> Doc ann
pretty Env
env = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
        [ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          ([Doc ann] -> Doc ann)
-> ([(Text, Type)] -> [Doc ann]) -> [(Text, Type)] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Type) -> Doc ann) -> [(Text, Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, Type
v) -> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type -> String
forall a. Show a => a -> String
show Type
v))
          ([(Text, Type)] -> Doc ann) -> [(Text, Type)] -> Doc ann
forall a b. (a -> b) -> a -> b
$ [(Text, Type)]
resolved
        , [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          ([Doc ann] -> Doc ann) -> (Env -> [Doc ann]) -> Env -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Type) -> Doc ann) -> [(Int, Type)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
k, Type
v) -> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
k Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Type -> String
forall a. Show a => a -> String
show Type
v))
          ([(Int, Type)] -> [Doc ann])
-> (Env -> [(Int, Type)]) -> Env -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Type -> [(Int, Type)]
forall a. IntMap a -> [(Int, a)]
IntMap.assocs
          (IntMap Type -> [(Int, Type)])
-> (Env -> IntMap Type) -> Env -> [(Int, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> IntMap Type
envVars
          (Env -> Doc ann) -> Env -> Doc ann
forall a b. (a -> b) -> a -> b
$ Env
env
        ]
      where
        resolved :: [(Text, Type)]
        resolved :: [(Text, Type)]
resolved = (State Env [(Text, Type)] -> Env -> [(Text, Type)])
-> Env -> State Env [(Text, Type)] -> [(Text, Type)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Env [(Text, Type)] -> Env -> [(Text, Type)]
forall s a. State s a -> s -> a
State.evalState Env
env (State Env [(Text, Type)] -> [(Text, Type)])
-> State Env [(Text, Type)] -> [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ do
            [(Text, Type)]
tys <- Map Text Type -> [(Text, Type)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map Text Type -> [(Text, Type)])
-> (Env -> Map Text Type) -> Env -> [(Text, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Text Type
envTypes (Env -> [(Text, Type)])
-> StateT Env Identity Env -> State Env [(Text, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Env Identity Env
forall s (m :: * -> *). MonadState s m => m s
State.get
            ((Text, Type) -> StateT Env Identity (Text, Type))
-> [(Text, Type)] -> State Env [(Text, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Text
n, Type
ty) -> (Text
n,) (Type -> (Text, Type))
-> StateT Env Identity Type -> StateT Env Identity (Text, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
ty Type
ty) [(Text, Type)]
tys


typeError :: (HasCallStack, Show a) => String -> [a] -> State Env b
typeError :: String -> [a] -> State Env b
typeError String
msg [a]
x = do
    Env
env <- StateT Env Identity Env
forall s (m :: * -> *). MonadState s m => m s
State.get
    String -> State Env b
forall a. HasCallStack => String -> a
error (String -> State Env b) -> String -> State Env b
forall a b. (a -> b) -> a -> b
$ String
msg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Doc Any -> String
forall a. Show a => a -> String
show ([Doc Any] -> Doc Any
forall ann. [Doc ann] -> Doc ann
vcat ([Doc Any] -> Doc Any) -> [Doc Any] -> Doc Any
forall a b. (a -> b) -> a -> b
$ (a -> Doc Any) -> [a] -> [Doc Any]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc Any) -> (a -> String) -> a -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) [a]
x [Doc Any] -> [Doc Any] -> [Doc Any]
forall a. [a] -> [a] -> [a]
++ [Env -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Env
env])

empty :: Env
empty :: Env
empty = Env :: [Text] -> [Text] -> Map Text Type -> IntMap Type -> Int -> Env
Env{Int
[Text]
Map Text Type
IntMap Type
forall a. [a]
forall a. IntMap a
envNextVar :: Int
envVars :: forall a. IntMap a
envTypes :: Map Text Type
envLocals :: forall a. [a]
envDiags :: forall a. [a]
envNextVar :: Int
envVars :: IntMap Type
envTypes :: Map Text Type
envLocals :: [Text]
envDiags :: [Text]
..}
  where
    envDiags :: [a]
envDiags = []
    envLocals :: [a]
envLocals = []
    envTypes :: Map Text Type
envTypes = [(Text, Type)] -> Map Text Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (Text
"nullptr"       , Type -> Type
T_Ptr Type
T_Top)
        , (Text
"NULL"          , Type -> Type
T_Ptr Type
T_Top)
        -- TODO(iphydf): Can't deal with variadic functions yet.
        , (Text
"LOGGER_ASSERT" , Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type
T_Bool, Type -> Type
T_Ptr Type
T_Char])
        , (Text
"LOGGER_DEBUG"  , Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type -> Type
T_Ptr Type
T_Char])
        , (Text
"LOGGER_ERROR"  , Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type -> Type
T_Ptr Type
T_Char])
        , (Text
"LOGGER_FATAL"  , Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type -> Type
T_Ptr Type
T_Char])
        , (Text
"LOGGER_INFO"   , Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type -> Type
T_Ptr Type
T_Char])
        , (Text
"LOGGER_TRACE"  , Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type -> Type
T_Ptr Type
T_Char])
        , (Text
"LOGGER_WARNING", Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr (Text -> Type
T_Name Text
"Logger"), Type -> Type
T_Ptr Type
T_Char])
        , (Text
"vpx_codec_control", Type -> [Type] -> Type
T_Func Type
T_Void [])
        , (Text
"crypto_memzero", Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr Type
T_Void, Type
T_Int])
        , (Text
"ioctl", Type -> [Type] -> Type
T_Func Type
T_Void [Type
T_Int, Type
T_Int, Type -> Type
T_Ptr Type
T_Void])
        , (Text
"memset", Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr Type
T_Void, Type
T_Int, Type
T_Int])
        , (Text
"memcpy", Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr Type
T_Void, Type -> Type
T_Ptr Type
T_Void, Type
T_Int])
        , (Text
"memmove", Type -> [Type] -> Type
T_Func Type
T_Void [Type -> Type
T_Ptr Type
T_Void, Type -> Type
T_Ptr Type
T_Void, Type
T_Int])
        , (Text
"snprintf", Type -> [Type] -> Type
T_Func Type
T_Void [])
        , (Text
"strerror_r", Type -> [Type] -> Type
T_Func Type
T_Void [])
        ]
    envVars :: IntMap a
envVars = IntMap a
forall a. IntMap a
IntMap.empty
    envNextVar :: Int
envNextVar = Int
0

newTyVar :: State Env Type
newTyVar :: StateT Env Identity Type
newTyVar = do
    env :: Env
env@Env{Int
envNextVar :: Int
envNextVar :: Env -> Int
envNextVar} <- StateT Env Identity Env
forall s (m :: * -> *). MonadState s m => m s
State.get
    Env -> StateT Env Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
State.put Env
env{envNextVar :: Int
envNextVar = Int
envNextVar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
    Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Int -> Type
T_Var Int
envNextVar

addTyVar :: Int -> Type -> State Env ()
addTyVar :: Int -> Type -> StateT Env Identity ()
addTyVar Int
v Type
ty =
    (Env -> Env) -> StateT Env Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Env -> Env) -> StateT Env Identity ())
-> (Env -> Env) -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ \env :: Env
env@Env{IntMap Type
envVars :: IntMap Type
envVars :: Env -> IntMap Type
envVars} ->
        Env
env{envVars :: IntMap Type
envVars = Int -> Type -> IntMap Type -> IntMap Type
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
v Type
ty IntMap Type
envVars}

addLocal :: Text -> State Env ()
addLocal :: Text -> StateT Env Identity ()
addLocal Text
n = (Env -> Env) -> StateT Env Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Env -> Env) -> StateT Env Identity ())
-> (Env -> Env) -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ \env :: Env
env@Env{[Text]
envLocals :: [Text]
envLocals :: Env -> [Text]
envLocals} -> Env
env{envLocals :: [Text]
envLocals = Text
nText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
envLocals}

dropLocals :: State Env ()
dropLocals :: StateT Env Identity ()
dropLocals = (Env -> Env) -> StateT Env Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Env -> Env) -> StateT Env Identity ())
-> (Env -> Env) -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ \env :: Env
env@Env{[Text]
envLocals :: [Text]
envLocals :: Env -> [Text]
envLocals, Map Text Type
envTypes :: Map Text Type
envTypes :: Env -> Map Text Type
envTypes} ->
    Env
env{envTypes :: Map Text Type
envTypes = (Text -> Map Text Type -> Map Text Type)
-> Map Text Type -> [Text] -> Map Text Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Map Text Type
envTypes [Text]
envLocals, envLocals :: [Text]
envLocals = []}

addName :: HasCallStack => Text -> Type -> State Env Type
addName :: Text -> Type -> StateT Env Identity Type
addName Text
n Type
ty = do
    String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"a: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
ty
    Maybe Type
found <- Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n (Map Text Type -> Maybe Type)
-> (Env -> Map Text Type) -> Env -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Text Type
envTypes (Env -> Maybe Type)
-> StateT Env Identity Env -> StateT Env Identity (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Env Identity Env
forall s (m :: * -> *). MonadState s m => m s
State.get
    case Maybe Type
found of
      Maybe Type
Nothing ->do
          (Env -> Env) -> StateT Env Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify ((Env -> Env) -> StateT Env Identity ())
-> (Env -> Env) -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ \env :: Env
env@Env{Map Text Type
envTypes :: Map Text Type
envTypes :: Env -> Map Text Type
envTypes} -> Env
env{envTypes :: Map Text Type
envTypes = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
n Type
ty Map Text Type
envTypes}
          Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
      Just Type
ty' -> HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
ty Type
ty'

getName :: HasCallStack => Text -> State Env Type
getName :: Text -> StateT Env Identity Type
getName Text
n = do
    String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"g " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
n
    Maybe Type
found <- Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
n (Map Text Type -> Maybe Type)
-> (Env -> Map Text Type) -> Env -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Map Text Type
envTypes (Env -> Maybe Type)
-> StateT Env Identity Env -> StateT Env Identity (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Env Identity Env
forall s (m :: * -> *). MonadState s m => m s
State.get
    String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"g " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Type -> String
forall a. Show a => a -> String
show Maybe Type
found
    case Maybe Type
found of
      Just Type
ok -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ok
      Maybe Type
Nothing -> HasCallStack => Text -> Type -> StateT Env Identity Type
Text -> Type -> StateT Env Identity Type
addName Text
n (Type -> StateT Env Identity Type)
-> StateT Env Identity Type -> StateT Env Identity Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT Env Identity Type
newTyVar

resolve :: Int -> State Env (Maybe Type)
resolve :: Int -> StateT Env Identity (Maybe Type)
resolve Int
v = do
    String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"r " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
v
    Maybe Type
found <- Int -> IntMap Type -> Maybe Type
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
v (IntMap Type -> Maybe Type)
-> (Env -> IntMap Type) -> Env -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> IntMap Type
envVars (Env -> Maybe Type)
-> StateT Env Identity Env -> StateT Env Identity (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Env Identity Env
forall s (m :: * -> *). MonadState s m => m s
State.get
    String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"r " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
v String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Type -> String
forall a. Show a => a -> String
show Maybe Type
found
    Maybe Type -> StateT Env Identity (Maybe Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
found


data HasRecursed
    = NotRecursed
    | HasRecursed


unifyRecursive :: HasCallStack => [(Type, Type)] -> Type -> Type -> State Env Type
unifyRecursive :: [(Type, Type)] -> Type -> Type -> StateT Env Identity Type
unifyRecursive [(Type, Type)]
stack Type
ty1 Type
ty2 | (Type
ty1, Type
ty2) (Type, Type) -> [(Type, Type)] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Type, Type)]
stack =
    String -> [(Type, Type)] -> StateT Env Identity Type
forall a b. (HasCallStack, Show a) => String -> [a] -> State Env b
typeError String
"recursive unification" [(Type, Type)]
stack
unifyRecursive [(Type, Type)]
stack Type
ty1 Type
ty2 = do
    String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"unify: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Type, Type) -> String
forall a. Show a => a -> String
show (Type
ty1, Type
ty2)
    Type
res <- HasRecursed -> Type -> Type -> StateT Env Identity Type
go HasRecursed
NotRecursed Type
ty1 Type
ty2
    case Type
res of
        Type
T_Bot -> String -> [(Type, Type)] -> StateT Env Identity Type
forall a b. (HasCallStack, Show a) => String -> [a] -> State Env b
typeError String
"bottom" ([(Type, Type)] -> StateT Env Identity Type)
-> [(Type, Type)] -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ (Type
ty1, Type
ty2)(Type, Type) -> [(Type, Type)] -> [(Type, Type)]
forall a. a -> [a] -> [a]
:[(Type, Type)]
stack
        Type
ok    -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ok
  where
    -- Equal types unify trivially.
    go :: HasRecursed -> Type -> Type -> StateT Env Identity Type
go HasRecursed
_ Type
a Type
b | Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a

    go HasRecursed
_ (T_Struct Map Text Type
a     ) (T_Struct Map Text Type
b     ) = Map Text Type -> Type
T_Struct   (Map Text Type -> Type)
-> StateT Env Identity (Map Text Type) -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Type -> StateT Env Identity Type)
-> Map Text Type
-> Map Text Type
-> StateT Env Identity (Map Text Type)
forall (m :: * -> *) k a.
(Monad m, Ord k) =>
(a -> a -> m a) -> Map k a -> Map k a -> m (Map k a)
unionWithM Type -> Type -> StateT Env Identity Type
unifyRec Map Text Type
a Map Text Type
b
    go HasRecursed
_ (T_InitList [Type]
la  ) (T_InitList [Type]
lb  ) = [Type] -> Type
T_InitList ([Type] -> Type)
-> StateT Env Identity [Type] -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> Type -> StateT Env Identity Type)
-> [Type] -> [Type] -> StateT Env Identity [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Type -> StateT Env Identity Type
unifyRec [Type]
la [Type]
lb
    go HasRecursed
_ (T_Func Type
ra [Type]
argsa) (T_Func Type
rb [Type]
argsb) = Type -> [Type] -> Type
T_Func     (Type -> [Type] -> Type)
-> StateT Env Identity Type -> StateT Env Identity ([Type] -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Type -> StateT Env Identity Type
unifyRec Type
ra Type
rb StateT Env Identity ([Type] -> Type)
-> StateT Env Identity [Type] -> StateT Env Identity Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Type -> Type -> StateT Env Identity Type)
-> [Type] -> [Type] -> StateT Env Identity [Type]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Type -> Type -> StateT Env Identity Type
unifyRec [Type]
argsa [Type]
argsb
    go HasRecursed
_ (T_Add Type
la Type
lb    ) (T_Add Type
ra Type
rb    ) = Type -> Type -> Type
T_Add      (Type -> Type -> Type)
-> StateT Env Identity Type -> StateT Env Identity (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Type -> StateT Env Identity Type
unifyRec Type
la Type
ra StateT Env Identity (Type -> Type)
-> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Type -> StateT Env Identity Type
unifyRec Type
lb Type
rb
    go HasRecursed
_ (T_Sub Type
la Type
lb    ) (T_Sub Type
ra Type
rb    ) = Type -> Type -> Type
T_Sub      (Type -> Type -> Type)
-> StateT Env Identity Type -> StateT Env Identity (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Type -> StateT Env Identity Type
unifyRec Type
la Type
ra StateT Env Identity (Type -> Type)
-> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Type -> StateT Env Identity Type
unifyRec Type
lb Type
rb

    go HasRecursed
_ (T_Intersect Type
a1 Type
a2) Type
b = (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Type -> Type -> StateT Env Identity Type
unifyRec Type
b [Type
a1, Type
a2]

    go HasRecursed
_ (T_Name Text
name) Type
b = do
        Type
r <- HasCallStack => Text -> StateT Env Identity Type
Text -> StateT Env Identity Type
getName Text
name
        String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"unify name: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" (= " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
r String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
b
        Type -> Type -> StateT Env Identity Type
unifyRec Type
b Type
r

    go HasRecursed
_ (T_Var Int
a) Type
b = do
        Maybe Type
res <- Int -> StateT Env Identity (Maybe Type)
resolve Int
a
        case Maybe Type
res of
          Maybe Type
Nothing -> do
              Int -> Type -> StateT Env Identity ()
addTyVar Int
a Type
b
              Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b
          Just resolved :: Type
resolved@T_Var{} ->
              Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
resolved
          Just Type
resolved ->
              Type -> Type -> StateT Env Identity Type
unifyRec Type
b Type
resolved

    go HasRecursed
_ (T_Add Type
l Type
r) b :: Type
b@T_Ptr{} = do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> StateT Env Identity Type
unifyRec Type
r Type
T_Int
        Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
b
    go HasRecursed
_ (T_Add Type
l Type
r) b :: Type
b@T_Arr{} = do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> StateT Env Identity Type
unifyRec Type
r Type
T_Int
        Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
b

    go HasRecursed
_ (T_Add Type
l Type
r) Type
T_Int = Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
T_Int StateT Env Identity Type
-> (Type -> StateT Env Identity Type) -> StateT Env Identity Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Type -> StateT Env Identity Type
unifyRec Type
r
    go HasRecursed
_ a :: Type
a@T_Add{} b :: Type
b@T_Sub{} = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
T_Intersect Type
a Type
b

    go HasRecursed
_ (T_Sub (T_Ptr Type
l) (T_Ptr Type
r)) Type
b = Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
r StateT Env Identity Type
-> StateT Env Identity Type -> StateT Env Identity Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Type -> StateT Env Identity Type
unifyRec Type
b Type
T_Int
    go HasRecursed
_ (T_Sub (T_Ptr Type
l) (T_Arr Type
r)) Type
b = Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
r StateT Env Identity Type
-> StateT Env Identity Type -> StateT Env Identity Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> Type -> StateT Env Identity Type
unifyRec Type
b Type
T_Int
    go HasRecursed
_ (T_Sub Type
l Type
T_Int) r :: Type
r@T_Ptr{} = Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
r
    go HasRecursed
_ (T_Sub Type
l Type
r) Type
T_Int = Type -> Type -> StateT Env Identity Type
unifyRec Type
l Type
T_Int StateT Env Identity Type
-> (Type -> StateT Env Identity Type) -> StateT Env Identity Type
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Type -> StateT Env Identity Type
unifyRec Type
r

    -- Dereference function pointers for unification.
    go HasRecursed
_ a :: Type
a@T_Func{} (T_Ptr Type
b) = Type -> Type -> StateT Env Identity Type
unifyRec Type
a Type
b

    -- Array and pointer types can unify and turn into pointer.
    go HasRecursed
_ (T_Arr Type
a) (T_Ptr Type
b) = Type -> Type
T_Ptr (Type -> Type)
-> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Type -> StateT Env Identity Type
unifyRec Type
a Type
b

    go HasRecursed
_ a :: Type
a@T_Struct{} T_InitList{} = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a
    go HasRecursed
_ a :: Type
a@T_Struct{} T_Name{} = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
a

    -- Arrays unify with all elements in their initialiser list.
    go HasRecursed
_ (T_Arr Type
a) (T_InitList [Type]
b) = (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Type -> Type -> StateT Env Identity Type
unifyRec Type
a [Type]
b

    -- `void *` unifies with any pointer type.
    go HasRecursed
_ (T_Ptr Type
T_Void) b :: Type
b@T_Ptr{} = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b
    -- Incompatible pointers unify to `void *`.
    go HasRecursed
_ T_Ptr{} T_Ptr{} = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
T_Ptr Type
T_Void

    go HasRecursed
_ Type
T_Int T_Ptr{} = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Bot

    -- `void` and the top type (null) unifies with anything
    go HasRecursed
_ Type
T_Void Type
b = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b
    go HasRecursed
_ Type
T_Top Type
b = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
b
    -- The bottom type turns everything into bottom.
    go HasRecursed
_ Type
T_Bot Type
_ = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Bot

    go HasRecursed
NotRecursed Type
a Type
b = HasRecursed -> Type -> Type -> StateT Env Identity Type
go HasRecursed
HasRecursed Type
b Type
a
    go HasRecursed
HasRecursed Type
a Type
b = String -> [(Type, Type)] -> StateT Env Identity Type
forall a b. (HasCallStack, Show a) => String -> [a] -> State Env b
typeError String
"unification" [(Type
a, Type
b)]

    unifyRec :: Type -> Type -> StateT Env Identity Type
unifyRec = HasCallStack =>
[(Type, Type)] -> Type -> Type -> StateT Env Identity Type
[(Type, Type)] -> Type -> Type -> StateT Env Identity Type
unifyRecursive ((Type
ty1, Type
ty2)(Type, Type) -> [(Type, Type)] -> [(Type, Type)]
forall a. a -> [a] -> [a]
:[(Type, Type)]
stack)


unify :: HasCallStack => Type -> Type -> State Env Type
unify :: Type -> Type -> StateT Env Identity Type
unify = HasCallStack =>
[(Type, Type)] -> Type -> Type -> StateT Env Identity Type
[(Type, Type)] -> Type -> Type -> StateT Env Identity Type
unifyRecursive []


inferBinaryExpr :: BinaryOp -> Type -> Type -> State Env Type
inferBinaryExpr :: BinaryOp -> Type -> Type -> StateT Env Identity Type
inferBinaryExpr BinaryOp
BopAnd Type
l Type
r    = (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Bool [Type
l, Type
r]
inferBinaryExpr BinaryOp
BopOr Type
l Type
r     = (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Bool [Type
l, Type
r]
inferBinaryExpr BinaryOp
BopLe Type
l Type
r     = Type
T_Bool Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopLt Type
l Type
r     = Type
T_Bool Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopGe Type
l Type
r     = Type
T_Bool Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopGt Type
l Type
r     = Type
T_Bool Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopEq Type
l Type
r     = Type
T_Bool Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopNe Type
l Type
r     = Type
T_Bool Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopMul Type
l Type
r    = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopMod Type
l Type
r    = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopDiv Type
l Type
r    = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopBitOr Type
l Type
r  = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopBitAnd Type
l Type
r = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopBitXor Type
l Type
r = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopLsh Type
l Type
r    = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopRsh Type
l Type
r    = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
inferBinaryExpr BinaryOp
BopPlus Type
l Type
r   = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
T_Add Type
l Type
r
inferBinaryExpr BinaryOp
BopMinus Type
l Type
r  = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
T_Sub Type
l Type
r


inferUnaryExpr :: UnaryOp -> Type -> State Env Type
inferUnaryExpr :: UnaryOp -> Type -> StateT Env Identity Type
inferUnaryExpr UnaryOp
UopAddress Type
e = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
T_Ptr Type
e
inferUnaryExpr UnaryOp
UopIncr Type
e    = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e
inferUnaryExpr UnaryOp
UopDecr Type
e    = Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e
inferUnaryExpr UnaryOp
UopNeg Type
e     = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Int Type
e
inferUnaryExpr UnaryOp
UopMinus Type
e   = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Int Type
e
inferUnaryExpr UnaryOp
UopNot Type
e     = HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Bool Type
e
inferUnaryExpr UnaryOp
UopDeref Type
e = do
    Type
memTy <- StateT Env Identity Type
newTyVar
    StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e (Type -> Type
T_Ptr Type
memTy)
    Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memTy


inferTypes :: NodeF (Lexeme Text) Type -> State Env Type
inferTypes :: NodeF (Lexeme Text) Type -> StateT Env Identity Type
inferTypes = \case
    SizeofExpr{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Int
    SizeofType{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Int
    LiteralExpr LiteralType
Bool Lexeme Text
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Bool
    LiteralExpr LiteralType
Char Lexeme Text
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Char
    LiteralExpr LiteralType
Int Lexeme Text
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Int
    LiteralExpr LiteralType
String Lexeme Text
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
T_Ptr Type
T_Char
    InitialiserList [Type]
tys -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
T_InitList [Type]
tys

    TyStruct (L AlexPosn
_ LexemeClass
_ Text
name) -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
T_Name Text
name
    TyFunc (L AlexPosn
_ LexemeClass
_ Text
name) -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
T_Name Text
name
    TyStd (L AlexPosn
_ LexemeClass
_ Text
name) ->
        case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Type
stdTypes of
          Maybe Type
Nothing -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
T_Name Text
name -- typeError "standard type" [name]
          Just Type
ty -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    TyUserDefined (L AlexPosn
_ LexemeClass
_ Text
name) -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
T_Name Text
name
    TyPointer Type
ty -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
T_Ptr Type
ty
    TyBitwise Type
ty -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    TyForce Type
ty -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    TyConst Type
ty -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    TyOwner Type
ty -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    NodeF (Lexeme Text) Type
Ellipsis -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void

    VLA Type
ty (L AlexPosn
_ LexemeClass
_ Text
name) Type
size -> do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Int Type
size
        Text -> StateT Env Identity ()
addLocal Text
name
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Type -> StateT Env Identity Type
Text -> Type -> StateT Env Identity Type
addName Text
name (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
T_Arr Type
ty
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    DeclSpecArray{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_ArrDim
    VarDecl Type
ty (L AlexPosn
_ LexemeClass
_ Text
name) [Type]
arrs -> do
        let ty' :: Type
ty' = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Type -> Type) -> Type -> Type -> Type
forall a b. a -> b -> a
const Type -> Type
T_Arr) Type
ty [Type]
arrs
        Text -> StateT Env Identity ()
addLocal Text
name
        HasCallStack => Text -> Type -> StateT Env Identity Type
Text -> Type -> StateT Env Identity Type
addName Text
name Type
ty'
    VarDeclStmt Type
_ Maybe Type
Nothing -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    VarDeclStmt Type
decl (Just Type
initExpr) -> do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
decl Type
initExpr
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    PreprocDefineConst (L AlexPosn
_ LexemeClass
_ Text
name) Type
ty -> do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Type -> StateT Env Identity Type
Text -> Type -> StateT Env Identity Type
addName Text
name Type
ty
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void

    VarExpr (L AlexPosn
_ LexemeClass
_ Text
name) -> do
        String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"infer var " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name
        HasCallStack => Text -> StateT Env Identity Type
Text -> StateT Env Identity Type
getName Text
name
    LiteralExpr LiteralType
ConstId (L AlexPosn
_ LexemeClass
_ Text
name) -> do
        String -> StateT Env Identity ()
forall (m :: * -> *). Monad m => String -> m ()
traceMaybe (String -> StateT Env Identity ())
-> String -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ String
"infer const " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
name
        HasCallStack => Text -> StateT Env Identity Type
Text -> StateT Env Identity Type
getName Text
name
    CastExpr Type
ty Type
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    CompoundLiteral Type
ty Type
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    DoWhileStmt Type
body Type
c -> Type
body Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
c Type
T_Bool
    WhileStmt Type
c Type
body -> Type
body Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
c Type
T_Bool
    ForStmt Type
_ Type
c Type
_ Type
body -> Type
body Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
c Type
T_Bool
    SwitchStmt Type
_ [Type]
body -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Void [Type]
body
    IfStmt Type
c Type
t (Just Type
e) -> do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
c Type
T_Bool
        HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
t Type
e
    IfStmt Type
c Type
t Maybe Type
Nothing -> Type
t Type -> StateT Env Identity Type -> StateT Env Identity Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
c Type
T_Bool
    CompoundStmt [Type]
body -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Void [Type]
body
    Return (Just Type
ty) -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    Return Maybe Type
Nothing -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    ParenExpr Type
e -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e
    AssignExpr Type
l AssignOp
AopPlus Type
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
l
    AssignExpr Type
l AssignOp
AopMinus Type
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
l
    AssignExpr Type
l AssignOp
_ Type
r -> HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
l Type
r
    BinaryExpr Type
l BinaryOp
op Type
r -> BinaryOp -> Type -> Type -> StateT Env Identity Type
inferBinaryExpr BinaryOp
op Type
l Type
r
    UnaryExpr UnaryOp
op Type
e -> UnaryOp -> Type -> StateT Env Identity Type
inferUnaryExpr UnaryOp
op Type
e
    TernaryExpr Type
c Type
t Type
e -> do
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Bool Type
c
        HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
t Type
e

    FunctionPrototype Type
retTy (L AlexPosn
_ LexemeClass
_ Text
name) [Type]
args -> do
        -- traceMaybe $ "f " <> show f
        HasCallStack => Text -> Type -> StateT Env Identity Type
Text -> Type -> StateT Env Identity Type
addName Text
name (Type -> StateT Env Identity Type)
-> Type -> StateT Env Identity Type
forall a b. (a -> b) -> a -> b
$ Type -> [Type] -> Type
T_Func Type
retTy [Type]
args
    FunctionCall Type
callee [Type]
args -> do
        Type
retTy <- StateT Env Identity Type
newTyVar
        -- traceMaybe ">>>>"
        -- traceMaybe $ show (T_Func retTy args)
        -- traceMaybe $ show callee
        -- traceMaybe "<<<<"
        Type
funTy <- HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify (Type -> [Type] -> Type
T_Func Type
retTy [Type]
args) Type
callee
        case Type
funTy of
          T_Func Type
result [Type]
_ -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
result
          Type
_               -> String -> [Type] -> StateT Env Identity Type
forall a b. (HasCallStack, Show a) => String -> [a] -> State Env b
typeError String
"function type" [Type
funTy]
    FunctionDefn Scope
_ Type
defnTy Type
body -> do
        StateT Env Identity ()
dropLocals
        Type
retTy <- StateT Env Identity Type
newTyVar
        -- Ignore parameter types, unify will zip [] with the params, resulting in [].
        Type
funTy <- HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify (Type -> [Type] -> Type
T_Func Type
retTy []) Type
defnTy
        case Type
funTy of
          T_Func Type
r [Type]
_ -> HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
r Type
body
          Type
_          -> String -> [Type] -> StateT Env Identity Type
forall a b. (HasCallStack, Show a) => String -> [a] -> State Env b
typeError String
"function defn" [Type
funTy]

    ExprStmt{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    NodeF (Lexeme Text) Type
Break -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    NodeF (Lexeme Text) Type
Continue -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    Goto{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    Default Type
e -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e
    Case Type
_ Type
e -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e
    Label Lexeme Text
_ Type
e -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e
    Comment{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    CommentExpr Type
_ Type
e -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
e

    PreprocDefineMacro (L AlexPosn
_ LexemeClass
_ Text
name) [Type]
_ Type
_ -> do
        Text -> StateT Env Identity ()
addLocal Text
name
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    PreprocUndef{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    PreprocScopedDefine Type
_ [Type]
body Type
_ -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Void [Type]
body
    MacroParam{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void
    MacroBodyStmt Type
body -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
body

    StaticAssert{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Void

    PreprocDefined{} -> Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
T_Bool
    PreprocIf Type
_ [Type]
t Type
e -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e [Type]
t
    PreprocIfdef Lexeme Text
_ [Type]
t Type
e -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e [Type]
t
    PreprocIfndef Lexeme Text
_ [Type]
t Type
e -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e [Type]
t
    PreprocElif Type
_ [Type]
t Type
e -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e [Type]
t
    PreprocElse [Type]
body -> (Type -> Type -> StateT Env Identity Type)
-> Type -> [Type] -> StateT Env Identity Type
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
T_Void [Type]
body

    ArrayAccess Type
arr Type
idx -> do
        Type
memTy <- StateT Env Identity Type
newTyVar
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
arr (Type -> Type
T_Ptr Type
memTy)
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
idx Type
T_Int
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memTy

    MemberAccess Type
e (L AlexPosn
_ LexemeClass
_ Text
mem) -> do
        Type
ty <- StateT Env Identity Type
newTyVar
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e (Map Text Type -> Type
T_Struct (Text -> Type -> Map Text Type
forall k a. k -> a -> Map k a
Map.singleton Text
mem Type
ty))
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty
    PointerAccess Type
e (L AlexPosn
_ LexemeClass
_ Text
mem) -> do
        Type
ty <- StateT Env Identity Type
newTyVar
        StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Type -> Type -> StateT Env Identity Type
Type -> Type -> StateT Env Identity Type
unify Type
e (Type -> Type
T_Ptr (Map Text Type -> Type
T_Struct (Text -> Type -> Map Text Type
forall k a. k -> a -> Map k a
Map.singleton Text
mem Type
ty)))
        Type -> StateT Env Identity Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ty

    NodeF (Lexeme Text) Type
x -> String -> [NodeF (Lexeme Text) Type] -> StateT Env Identity Type
forall a b. (HasCallStack, Show a) => String -> [a] -> State Env b
typeError String
"unhandled" [NodeF (Lexeme Text) Type
x]

linter :: AstActions (State Env) Text
linter :: AstActions (State Env) Text
linter = AstActions (State Env) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: String
-> Node (Lexeme Text)
-> StateT Env Identity ()
-> StateT Env Identity ()
doNode = \String
_file Node (Lexeme Text)
node StateT Env Identity ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            FunctionDefn{} -> StateT Env Identity Type -> StateT Env Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Env Identity Type -> StateT Env Identity ())
-> StateT Env Identity Type -> StateT Env Identity ()
forall a b. (a -> b) -> a -> b
$ (NodeF (Lexeme Text) Type -> StateT Env Identity Type)
-> Node (Lexeme Text) -> StateT Env Identity Type
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Traversable t) =>
(t a -> m a) -> Fix t -> m a
foldFixM NodeF (Lexeme Text) Type -> StateT Env Identity Type
inferTypes Node (Lexeme Text)
node

            NodeF (Lexeme Text) (Node (Lexeme Text))
_              -> StateT Env Identity ()
act
    }

analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Text]
analyse :: [(String, [Node (Lexeme Text)])] -> [Text]
analyse = [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ([(String, [Node (Lexeme Text)])] -> [Text])
-> [(String, [Node (Lexeme Text)])]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> [Text]
envDiags (Env -> [Text])
-> ([(String, [Node (Lexeme Text)])] -> Env)
-> [(String, [Node (Lexeme Text)])]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT Env Identity () -> Env -> Env)
-> Env -> StateT Env Identity () -> Env
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Env Identity () -> Env -> Env
forall s a. State s a -> s -> s
State.execState Env
empty (StateT Env Identity () -> Env)
-> ([(String, [Node (Lexeme Text)])] -> StateT Env Identity ())
-> [(String, [Node (Lexeme Text)])]
-> Env
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State Env) Text
-> [(String, [Node (Lexeme Text)])] -> StateT Env Identity ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State Env) Text
linter

descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr :: ([(String, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr = ([(String, [Node (Lexeme Text)])] -> [Text]
analyse, (Text
"type-check", [Text] -> Text
Text.unlines
    [ Text
"Performs Hindley-Milner like type checking."
    , Text
""
    , Text
"This is very much work in progress, so it may fail in cryptic ways. Talk to"
    , Text
"@iphydf if it produces an error."
    , Text
""
    , Text
"**Reason:** this allows us to validate various difficult to check aspects of C."
    ]))