{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE OverloadedStrings     #-}

module Tokstyle.Linter.TypeCheck (descr) where

import           Control.Monad               (forM, forM_, void, when, zipWithM,
                                              zipWithM_)
import           Control.Monad.Except        hiding (catchError)
import           Control.Monad.State.Strict
import           Data.Fix                    (Fix (..))
import           Data.Map.Strict             (Map)
import qualified Data.Map.Strict             as Map
import           Data.Maybe                  (mapMaybe)
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             (AssignOp (..), BinaryOp (..),
                                              HasLocation, Lexeme (..),
                                              LiteralType (..), Node,
                                              NodeF (..), UnaryOp (..),
                                              lexemeText)
import qualified Language.Cimple             as C
import           Language.Cimple.Diagnostics (warn)
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)

-- | The core type system of our linter. It's a Hindley-Milner style type system.
data Type
    = TInt
    | TFloat
    | TBool
    | TChar
    | TString
    | TUnit -- void
    | TPointer Type
    | TFunc [Type] Type Bool
    | TStruct Text (Map Text Type)
    | TUnion Text (Map Text Type)
    | TUserDefined Text
    | TNullPtr
    | TVar TVar
    deriving (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)

-- Custom Eq for nominal typing of structs
instance Eq Type where
    Type
TInt == :: Type -> Type -> Bool
== Type
TInt = Bool
True
    Type
TFloat == Type
TFloat = Bool
True
    Type
TBool == Type
TBool = Bool
True
    Type
TChar == Type
TChar = Bool
True
    Type
TString == Type
TString = Bool
True
    Type
TUnit == Type
TUnit = Bool
True
    (TPointer Type
t1) == (TPointer Type
t2) = Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t2
    (TFunc [Type]
args1 Type
ret1 Bool
v1) == (TFunc [Type]
args2 Type
ret2 Bool
v2) = [Type]
args1 [Type] -> [Type] -> Bool
forall a. Eq a => a -> a -> Bool
== [Type]
args2 Bool -> Bool -> Bool
&& Type
ret1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
ret2 Bool -> Bool -> Bool
&& Bool
v1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
v2
    (TStruct Text
name1 Map Text Type
_) == (TStruct Text
name2 Map Text Type
_) = Text
name1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name2
    (TUnion Text
name1 Map Text Type
_) == (TUnion Text
name2 Map Text Type
_) = Text
name1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name2
    (TUserDefined Text
name1) == (TUserDefined Text
name2) = Text
name1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
name2
    Type
TNullPtr == Type
TNullPtr = Bool
True
    (TVar TVar
v1) == (TVar TVar
v2) = TVar
v1 TVar -> TVar -> Bool
forall a. Eq a => a -> a -> Bool
== TVar
v2
    Type
_ == Type
_ = Bool
False

-- | A type variable.
newtype TVar = TV Int deriving (TVar -> TVar -> Bool
(TVar -> TVar -> Bool) -> (TVar -> TVar -> Bool) -> Eq TVar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TVar -> TVar -> Bool
$c/= :: TVar -> TVar -> Bool
== :: TVar -> TVar -> Bool
$c== :: TVar -> TVar -> Bool
Eq, Eq TVar
Eq TVar
-> (TVar -> TVar -> Ordering)
-> (TVar -> TVar -> Bool)
-> (TVar -> TVar -> Bool)
-> (TVar -> TVar -> Bool)
-> (TVar -> TVar -> Bool)
-> (TVar -> TVar -> TVar)
-> (TVar -> TVar -> TVar)
-> Ord TVar
TVar -> TVar -> Bool
TVar -> TVar -> Ordering
TVar -> TVar -> TVar
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 :: TVar -> TVar -> TVar
$cmin :: TVar -> TVar -> TVar
max :: TVar -> TVar -> TVar
$cmax :: TVar -> TVar -> TVar
>= :: TVar -> TVar -> Bool
$c>= :: TVar -> TVar -> Bool
> :: TVar -> TVar -> Bool
$c> :: TVar -> TVar -> Bool
<= :: TVar -> TVar -> Bool
$c<= :: TVar -> TVar -> Bool
< :: TVar -> TVar -> Bool
$c< :: TVar -> TVar -> Bool
compare :: TVar -> TVar -> Ordering
$ccompare :: TVar -> TVar -> Ordering
$cp1Ord :: Eq TVar
Ord)

instance Show TVar where
    show :: TVar -> String
show (TV Int
i) = String
"t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

instance Show Type where
    show :: Type -> String
show Type
TInt               = String
"int"
    show Type
TFloat             = String
"float"
    show Type
TBool              = String
"bool"
    show Type
TChar              = String
"char"
    show Type
TString            = String
"string"
    show Type
TUnit              = String
"void"
    show (TPointer Type
t)       = Type -> String
forall a. Show a => a -> String
show Type
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"*"
    show (TFunc [Type]
args Type
ret Bool
isVariadic)   = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack (Text -> [Text] -> Text
Text.intercalate Text
", " ((Type -> Text) -> [Type] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
Text.pack (String -> Text) -> (Type -> String) -> Type -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> String
forall a. Show a => a -> String
show) [Type]
args)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
isVariadic then String
", ..." else String
"") String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") -> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ret
    show (TStruct Text
name Map Text Type
_)   = String
"struct " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
name
    show (TUnion Text
name Map Text Type
_)    = String
"union " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
Text.unpack Text
name
    show (TUserDefined Text
name)= Text -> String
Text.unpack Text
name
    show Type
TNullPtr           = String
"nullptr_t"
    show (TVar TVar
v)           = TVar -> String
forall a. Show a => a -> String
show TVar
v

-- | A type scheme, used for polymorphism.
data Scheme = Forall [TVar] Type
    deriving (Scheme -> Scheme -> Bool
(Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool) -> Eq Scheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scheme -> Scheme -> Bool
$c/= :: Scheme -> Scheme -> Bool
== :: Scheme -> Scheme -> Bool
$c== :: Scheme -> Scheme -> Bool
Eq, Eq Scheme
Eq Scheme
-> (Scheme -> Scheme -> Ordering)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Scheme)
-> (Scheme -> Scheme -> Scheme)
-> Ord Scheme
Scheme -> Scheme -> Bool
Scheme -> Scheme -> Ordering
Scheme -> Scheme -> Scheme
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 :: Scheme -> Scheme -> Scheme
$cmin :: Scheme -> Scheme -> Scheme
max :: Scheme -> Scheme -> Scheme
$cmax :: Scheme -> Scheme -> Scheme
>= :: Scheme -> Scheme -> Bool
$c>= :: Scheme -> Scheme -> Bool
> :: Scheme -> Scheme -> Bool
$c> :: Scheme -> Scheme -> Bool
<= :: Scheme -> Scheme -> Bool
$c<= :: Scheme -> Scheme -> Bool
< :: Scheme -> Scheme -> Bool
$c< :: Scheme -> Scheme -> Bool
compare :: Scheme -> Scheme -> Ordering
$ccompare :: Scheme -> Scheme -> Ordering
$cp1Ord :: Eq Scheme
Ord, Int -> Scheme -> ShowS
[Scheme] -> ShowS
Scheme -> String
(Int -> Scheme -> ShowS)
-> (Scheme -> String) -> ([Scheme] -> ShowS) -> Show Scheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scheme] -> ShowS
$cshowList :: [Scheme] -> ShowS
show :: Scheme -> String
$cshow :: Scheme -> String
showsPrec :: Int -> Scheme -> ShowS
$cshowsPrec :: Int -> Scheme -> ShowS
Show)

-- Substitution

-- | A substitution is a mapping from type variables to types.
type Subst = Map TVar Type

-- | A class for types that can have substitutions applied to them.
class Substitutable a where
    apply :: Subst -> a -> a
    ftv   :: a -> Set TVar

instance Substitutable Type where
    apply :: Subst -> Type -> Type
apply Subst
s t :: Type
t@(TVar TVar
a)            = Type -> TVar -> Subst -> Type
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Type
t TVar
a Subst
s
    apply Subst
s (TPointer Type
t)          = Type -> Type
TPointer (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
t)
    apply Subst
s (TFunc [Type]
args Type
ret Bool
v)    = [Type] -> Type -> Bool -> Type
TFunc ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s) [Type]
args) (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
ret) Bool
v
    apply Subst
s (TStruct Text
name Map Text Type
fields) = Text -> Map Text Type -> Type
TStruct Text
name ((Type -> Type) -> Map Text Type -> Map Text Type
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s) Map Text Type
fields)
    apply Subst
s (TUnion Text
name Map Text Type
fields)  = Text -> Map Text Type -> Type
TUnion Text
name ((Type -> Type) -> Map Text Type -> Map Text Type
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s) Map Text Type
fields)
    apply Subst
_ Type
t                     = Type
t

    ftv :: Type -> Set TVar
ftv (TVar TVar
a)           = TVar -> Set TVar
forall a. a -> Set a
Set.singleton TVar
a
    ftv (TPointer Type
t)       = Type -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv Type
t
    ftv (TFunc [Type]
args Type
ret Bool
_) = [Set TVar] -> Set TVar
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ((Type -> Set TVar) -> [Type] -> [Set TVar]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv [Type]
args) Set TVar -> Set TVar -> Set TVar
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Type -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv Type
ret
    ftv (TStruct Text
_ Map Text Type
fields) = [Type] -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv (Map Text Type -> [Type]
forall k a. Map k a -> [a]
Map.elems Map Text Type
fields)
    ftv (TUnion Text
_ Map Text Type
fields)  = [Type] -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv (Map Text Type -> [Type]
forall k a. Map k a -> [a]
Map.elems Map Text Type
fields)
    ftv Type
_                  = Set TVar
forall a. Set a
Set.empty

instance Substitutable Scheme where
    apply :: Subst -> Scheme -> Scheme
apply Subst
s (Forall [TVar]
vars Type
t) = [TVar] -> Type -> Scheme
Forall [TVar]
vars (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply ((TVar -> Subst -> Subst) -> Subst -> [TVar] -> Subst
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TVar -> Subst -> Subst
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Subst
s [TVar]
vars) Type
t)
    ftv :: Scheme -> Set TVar
ftv (Forall [TVar]
vars Type
t)     = Type -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv Type
t Set TVar -> Set TVar -> Set TVar
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [TVar] -> Set TVar
forall a. Ord a => [a] -> Set a
Set.fromList [TVar]
vars

instance Substitutable a => Substitutable [a] where
    apply :: Subst -> [a] -> [a]
apply = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> a) -> [a] -> [a])
-> (Subst -> a -> a) -> Subst -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Subst -> a -> a
forall a. Substitutable a => Subst -> a -> a
apply
    ftv :: [a] -> Set TVar
ftv   = (a -> Set TVar -> Set TVar) -> Set TVar -> [a] -> Set TVar
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Set TVar -> Set TVar -> Set TVar
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set TVar -> Set TVar -> Set TVar)
-> (a -> Set TVar) -> a -> Set TVar -> Set TVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv) Set TVar
forall a. Set a
Set.empty

instance Substitutable v => Substitutable (Map k v) where
    apply :: Subst -> Map k v -> Map k v
apply Subst
s = (v -> v) -> Map k v -> Map k v
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Subst -> v -> v
forall a. Substitutable a => Subst -> a -> a
apply Subst
s)
    ftv :: Map k v -> Set TVar
ftv = [v] -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv ([v] -> Set TVar) -> (Map k v -> [v]) -> Map k v -> Set TVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [v]
forall k a. Map k a -> [a]
Map.elems

-- Environments

-- | The type environment maps variable names to their type schemes.
type TypeEnv = Map Text Scheme
-- | The struct environment maps struct names to their field definitions.
type StructEnv = Map Text (Map Text Type)
-- | The union environment maps union names to their field definitions.
type UnionEnv = Map Text (Map Text Type)
-- | The typedef environment maps typedef names to their underlying types.
type TypedefEnv = Map Text Type

-- Linter State

-- | The state of the type checker.
data LinterState = LinterState
    { LinterState -> TypeEnv
typeEnv      :: TypeEnv
    , LinterState -> StructEnv
structEnv    :: StructEnv
    , LinterState -> StructEnv
unionEnv     :: UnionEnv
    , LinterState -> Map Text Type
typedefEnv   :: TypedefEnv
    , LinterState -> Subst
subst        :: Subst
    , LinterState -> Int
freshCounter :: Int
    , LinterState -> String
currentFile  :: FilePath
    }

-- | The linter monad.
type LinterM a = StateT LinterState (State [Text]) a

-- | A local error handler.
catchError :: LinterM a -> (Text -> LinterM a) -> LinterM a
catchError :: LinterM a -> (Text -> LinterM a) -> LinterM a
catchError LinterM a
action Text -> LinterM a
handler = do
    LinterState
st <- StateT LinterState (State [Text]) LinterState
forall s (m :: * -> *). MonadState s m => m s
get
    let res :: (a, [Text])
res = State [Text] a -> [Text] -> (a, [Text])
forall s a. State s a -> s -> (a, s)
runState (LinterM a -> LinterState -> State [Text] a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT LinterM a
action LinterState
st) []
    case (a, [Text])
res of
        (a
val, []) -> a -> LinterM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val
        (a
_, [Text]
errs) -> Text -> LinterM a
handler ([Text] -> Text
Text.unlines [Text]
errs)


-- Monad Helpers

-- | Generate a fresh type variable.
fresh :: LinterM Type
fresh :: LinterM Type
fresh = do
    LinterState
s <- StateT LinterState (State [Text]) LinterState
forall s (m :: * -> *). MonadState s m => m s
get
    let i :: Int
i = LinterState -> Int
freshCounter LinterState
s
    LinterState -> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put LinterState
s { freshCounter :: Int
freshCounter = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 }
    Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ TVar -> Type
TVar (Int -> TVar
TV Int
i)

-- | Add a type error to the list of diagnostics.
addError :: HasLocation a => a -> Text -> LinterM ()
addError :: a -> Text -> StateT LinterState (State [Text]) ()
addError a
loc Text
msg = do
    String
file <- (LinterState -> String) -> StateT LinterState (State [Text]) String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> String
currentFile
    StateT [Text] Identity () -> StateT LinterState (State [Text]) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT [Text] Identity () -> StateT LinterState (State [Text]) ())
-> StateT [Text] Identity ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ String -> a -> Text -> StateT [Text] Identity ()
forall at diags.
(HasLocation at, HasDiagnostics diags) =>
String -> at -> Text -> DiagnosticsT diags ()
warn String
file a
loc Text
msg

-- | Run a computation in a modified type environment.
withEnv :: (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv :: (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv TypeEnv -> TypeEnv
f LinterM a
m = do
    TypeEnv
oldEnv <- (LinterState -> TypeEnv)
-> StateT LinterState (State [Text]) TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> TypeEnv
typeEnv
    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typeEnv :: TypeEnv
typeEnv = TypeEnv -> TypeEnv
f TypeEnv
oldEnv }
    a
val <- LinterM a
m
    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typeEnv :: TypeEnv
typeEnv = TypeEnv
oldEnv }
    a -> LinterM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

-- Unification

-- | Compose two substitutions.
composeSubst :: Subst -> Subst -> Subst
composeSubst :: Subst -> Subst -> Subst
composeSubst Subst
s1 Subst
s2 = (Type -> Type) -> Subst -> Subst
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s1) Subst
s2 Subst -> Subst -> Subst
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Subst
s1

-- | Unify two types.
unify :: HasLocation a => a -> Text -> Type -> Type -> LinterM ()
unify :: a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc Text
context Type
t1 Type
t2 = do
    Subst
s <- (LinterState -> Subst) -> StateT LinterState (State [Text]) Subst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Subst
subst
    Type
rT1 <- Type -> LinterM Type
resolveType (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
t1)
    Type
rT2 <- Type -> LinterM Type
resolveType (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
t2)
    case (Type
rT1, Type
rT2) of
        (TPointer (TVar TVar
a), TPointer Type
t) -> a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
unifyVar a
loc Text
context TVar
a Type
t
        (TPointer Type
t, TPointer (TVar TVar
a)) -> a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
unifyVar a
loc Text
context TVar
a Type
t
        (TVar TVar
a, Type
t) -> a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
unifyVar a
loc Text
context TVar
a Type
t
        (Type
t, TVar TVar
a) -> a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
unifyVar a
loc Text
context TVar
a Type
t
        (Type
TNullPtr, TPointer Type
_) -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (TPointer Type
_, Type
TNullPtr) -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (TPointer Type
t, Type
t') | Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t' -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Type
t, TPointer Type
t') | Type
t Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t' -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (TFunc [Type]
args1 Type
ret1 Bool
_, TPointer (TFunc [Type]
args2 Type
ret2 Bool
_)) -> a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc Text
context ([Type] -> Type -> Bool -> Type
TFunc [Type]
args1 Type
ret1 Bool
False) ([Type] -> Type -> Bool -> Type
TFunc [Type]
args2 Type
ret2 Bool
False)
        (TPointer (TFunc [Type]
args1 Type
ret1 Bool
_), TFunc [Type]
args2 Type
ret2 Bool
_) -> a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc Text
context ([Type] -> Type -> Bool -> Type
TFunc [Type]
args1 Type
ret1 Bool
False) ([Type] -> Type -> Bool -> Type
TFunc [Type]
args2 Type
ret2 Bool
False)
        (TFunc [Type]
args1 Type
ret1 Bool
v1, TFunc [Type]
args2 Type
ret2 Bool
_v2) -> do
            if Bool
v1
            then do
                Bool
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args2) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$
                    a -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError a
loc (Text
"mismatched number of arguments in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                   Text
": expected at least " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args1)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                   Text
", but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args2)))
                let ([Type]
args2_fixed, [Type]
_args2_variadic) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args1) [Type]
args2
                ((Type, Int) -> Type -> StateT LinterState (State [Text]) ())
-> [(Type, Int)] -> [Type] -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\(Type
t1', Int
i) Type
t2' -> a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc (Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (argument " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Int
i :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") Type
t1' Type
t2') ([Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
args1 [Int
1..]) [Type]
args2_fixed
            else do
                Bool
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args2) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$
                    a -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError a
loc (Text
"mismatched number of arguments in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                   Text
": expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args1)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
                                   Text
", but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
args2)))
                ((Type, Int) -> Type -> StateT LinterState (State [Text]) ())
-> [(Type, Int)] -> [Type] -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\(Type
t1', Int
i) Type
t2' -> a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc (Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (argument " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Int -> String
forall a. Show a => a -> String
show (Int
i :: Int)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")") Type
t1' Type
t2') ([Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
args1 [Int
1..]) [Type]
args2
            a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc (Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (return type)") Type
ret1 Type
ret2
        (TUnion Text
n1 Map Text Type
_, TUnion Text
n2 Map Text Type
_) | Text
n1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
n2 -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Type
t1'', Type
t2'') | Type
t1'' Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t2'' -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Type, Type)
_ -> a -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError a
loc (Text -> StateT LinterState (State [Text]) ())
-> Text -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Text
"type mismatch in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
rT1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", but got " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
rT2)

-- | Unify a type variable with a type.
unifyVar :: HasLocation a => a -> Text -> TVar -> Type -> LinterM ()
unifyVar :: a -> Text -> TVar -> Type -> StateT LinterState (State [Text]) ()
unifyVar a
loc Text
context TVar
a Type
t = do
    Subst
s <- (LinterState -> Subst) -> StateT LinterState (State [Text]) Subst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Subst
subst
    if | Just Type
t' <- TVar -> Subst -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TVar
a Subst
s -> a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify a
loc Text
context Type
t' Type
t
       | TVar -> Type
TVar TVar
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       | TVar
a TVar -> Set TVar -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Type -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv Type
t -> a -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError a
loc (Text -> StateT LinterState (State [Text]) ())
-> Text -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Text
"occurs check fails in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
context Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (TVar -> String
forall a. Show a => a -> String
show TVar
a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" vs " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
t)
       | Bool
otherwise -> do
            let newSubst :: Subst
newSubst = TVar -> Type -> Subst
forall k a. k -> a -> Map k a
Map.singleton TVar
a Type
t
            (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
st -> LinterState
st { subst :: Subst
subst = Subst -> Subst -> Subst
composeSubst Subst
newSubst (LinterState -> Subst
subst LinterState
st) }

-- Type Inference

-- | Generalize a type into a type scheme.
generalize :: TypeEnv -> Type -> LinterM Scheme
generalize :: TypeEnv -> Type -> LinterM Scheme
generalize TypeEnv
env Type
t = do
    Subst
s <- (LinterState -> Subst) -> StateT LinterState (State [Text]) Subst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Subst
subst
    let t' :: Type
t' = Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
t
    let env' :: TypeEnv
env' = Subst -> TypeEnv -> TypeEnv
forall a. Substitutable a => Subst -> a -> a
apply Subst
s TypeEnv
env
    Scheme -> LinterM Scheme
forall (m :: * -> *) a. Monad m => a -> m a
return (Scheme -> LinterM Scheme) -> Scheme -> LinterM Scheme
forall a b. (a -> b) -> a -> b
$ [TVar] -> Type -> Scheme
Forall (Set TVar -> [TVar]
forall a. Set a -> [a]
Set.toList (Set TVar -> [TVar]) -> Set TVar -> [TVar]
forall a b. (a -> b) -> a -> b
$ Type -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv Type
t' Set TVar -> Set TVar -> Set TVar
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` TypeEnv -> Set TVar
forall a. Substitutable a => a -> Set TVar
ftv TypeEnv
env') Type
t'

-- | Instantiate a type scheme into a type.
instantiate :: Scheme -> LinterM Type
instantiate :: Scheme -> LinterM Type
instantiate (Forall [TVar]
vars Type
t) = do
    Subst
s <- (LinterState -> Subst) -> StateT LinterState (State [Text]) Subst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Subst
subst
    Subst
freshSubst <- ([(TVar, Type)] -> Subst)
-> StateT LinterState (State [Text]) [(TVar, Type)]
-> StateT LinterState (State [Text]) Subst
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(TVar, Type)] -> Subst
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (StateT LinterState (State [Text]) [(TVar, Type)]
 -> StateT LinterState (State [Text]) Subst)
-> StateT LinterState (State [Text]) [(TVar, Type)]
-> StateT LinterState (State [Text]) Subst
forall a b. (a -> b) -> a -> b
$ [TVar]
-> (TVar -> StateT LinterState (State [Text]) (TVar, Type))
-> StateT LinterState (State [Text]) [(TVar, Type)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TVar]
vars ((TVar -> StateT LinterState (State [Text]) (TVar, Type))
 -> StateT LinterState (State [Text]) [(TVar, Type)])
-> (TVar -> StateT LinterState (State [Text]) (TVar, Type))
-> StateT LinterState (State [Text]) [(TVar, Type)]
forall a b. (a -> b) -> a -> b
$ \TVar
v -> do
        Type
v' <- LinterM Type
fresh
        (TVar, Type) -> StateT LinterState (State [Text]) (TVar, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (TVar
v, Type
v')
    Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply (Subst -> Subst -> Subst
composeSubst Subst
freshSubst Subst
s) Type
t

-- | Convert a Cimple AST type to a linter type.
cimpleToType :: Node (Lexeme Text) -> LinterM Type
cimpleToType :: Node (Lexeme Text) -> LinterM Type
cimpleToType (Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"void")   -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TUnit
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"float")  -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"int")    -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"long")   -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"long int") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"long signed int") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"signed int") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"unsigned") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"unsigned int") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"unsigned long") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"unsigned long long") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"uint8_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"uint16_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"uint32_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"uint64_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"int8_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"int16_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"int32_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"int64_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"size_t") -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"char")   -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TChar
    C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"bool")   -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
    C.TyPointer (Fix (C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"void"))) -> Type -> Type
TPointer (Type -> Type) -> LinterM Type -> LinterM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LinterM Type
fresh
    C.TyPointer Node (Lexeme Text)
t            -> Type -> Type
TPointer (Type -> Type) -> LinterM Type -> LinterM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
t
    C.TyConst Node (Lexeme Text)
t              -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
t
    C.TyOwner Node (Lexeme Text)
t              -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
t
    C.TyNullable Node (Lexeme Text)
t           -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
t
    C.TyNonnull Node (Lexeme Text)
t            -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
t
    C.TyUserDefined (L AlexPosn
_ LexemeClass
_ Text
name) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
TUserDefined Text
name
    C.TyStruct (L AlexPosn
_ LexemeClass
_ Text
name)  -> do
        StructEnv
senv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
structEnv
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TStruct Text
name (Map Text Type -> Text -> StructEnv -> Map Text Type
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Text Type
forall k a. Map k a
Map.empty Text
name StructEnv
senv)
    C.TyUnion (L AlexPosn
_ LexemeClass
_ Text
name) -> do
        StructEnv
uenv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
unionEnv
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TUnion Text
name (Map Text Type -> Text -> StructEnv -> Map Text Type
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map Text Type
forall k a. Map k a
Map.empty Text
name StructEnv
uenv)
    C.TyFunc (L AlexPosn
_ LexemeClass
_ Text
name)    -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
TUserDefined Text
name
    NodeF (Lexeme Text) (Node (Lexeme Text))
_                        -> LinterM Type
fresh

-- | Resolve a type by looking up typedefs.
resolveType :: Type -> LinterM Type
resolveType :: Type -> LinterM Type
resolveType (TUserDefined Text
name) = do
    Map Text Type
tenv <- (LinterState -> Map Text Type)
-> StateT LinterState (State [Text]) (Map Text Type)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Map Text Type
typedefEnv
    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
tenv of
        Just Type
t  -> Type -> LinterM Type
resolveType Type
t
        Maybe Type
Nothing -> do
            StructEnv
senv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
structEnv
            case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
senv of
                Just Map Text Type
fields -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TStruct Text
name Map Text Type
fields
                Maybe (Map Text Type)
Nothing     -> do
                    StructEnv
uenv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
unionEnv
                    case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
uenv of
                        Just Map Text Type
fields -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TUnion Text
name Map Text Type
fields
                        Maybe (Map Text Type)
Nothing     -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Type
TUserDefined Text
name
resolveType (TStruct Text
name Map Text Type
_) = do
    StructEnv
senv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
structEnv
    case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
senv of
        Just Map Text Type
fields -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TStruct Text
name Map Text Type
fields
        Maybe (Map Text Type)
Nothing     -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TStruct Text
name Map Text Type
forall k a. Map k a
Map.empty
resolveType (TUnion Text
name Map Text Type
_) = do
    StructEnv
uenv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
unionEnv
    case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
uenv of
        Just Map Text Type
fields -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TUnion Text
name Map Text Type
fields
        Maybe (Map Text Type)
Nothing     -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Type -> Type
TUnion Text
name Map Text Type
forall k a. Map k a
Map.empty
resolveType (TPointer Type
t) = Type -> Type
TPointer (Type -> Type) -> LinterM Type -> LinterM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> LinterM Type
resolveType Type
t
resolveType (TFunc [Type]
args Type
ret Bool
v) = [Type] -> Type -> Bool -> Type
TFunc ([Type] -> Type -> Bool -> Type)
-> StateT LinterState (State [Text]) [Type]
-> StateT LinterState (State [Text]) (Type -> Bool -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> LinterM Type)
-> [Type] -> StateT LinterState (State [Text]) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> LinterM Type
resolveType [Type]
args StateT LinterState (State [Text]) (Type -> Bool -> Type)
-> LinterM Type -> StateT LinterState (State [Text]) (Bool -> Type)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> LinterM Type
resolveType Type
ret StateT LinterState (State [Text]) (Bool -> Type)
-> StateT LinterState (State [Text]) Bool -> LinterM Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> StateT LinterState (State [Text]) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
v
resolveType Type
t = Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t

-- | Infer the type of an expression.
inferExpr :: Node (Lexeme Text) -> LinterM Type
inferExpr :: Node (Lexeme Text) -> LinterM Type
inferExpr n :: Node (Lexeme Text)
n@(Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    C.MacroBodyStmt Node (Lexeme Text)
e -> Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
    C.MacroBodyFunCall Node (Lexeme Text)
e -> Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
    C.CompoundStmt [Node (Lexeme Text)]
stmts -> do
        Type
retType <- LinterM Type
fresh
        [Node (Lexeme Text)]
-> Type -> StateT LinterState (State [Text]) ()
checkStmts [Node (Lexeme Text)]
stmts Type
retType
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TUnit
    C.DoWhileStmt Node (Lexeme Text)
body Node (Lexeme Text)
cond -> do
        Type
retType <- LinterM Type
fresh
        Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
retType
        Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TUnit
    C.InitialiserList [Node (Lexeme Text)]
es -> do
        Type
elemType <- LinterM Type
fresh
        [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node (Lexeme Text)]
es ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
e -> do
            Type
t <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"initialiser list element" Type
elemType Type
t
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
TPointer Type
elemType
    C.CommentExpr Node (Lexeme Text)
e Node (Lexeme Text)
_ -> Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
    C.CompoundExpr Node (Lexeme Text)
_ Node (Lexeme Text)
_ -> LinterM Type
fresh
    C.MacroParam l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name) -> do
        Maybe Scheme
mScheme <- (LinterState -> Maybe Scheme)
-> StateT LinterState (State [Text]) (Maybe Scheme)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Text -> TypeEnv -> Maybe Scheme
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (TypeEnv -> Maybe Scheme)
-> (LinterState -> TypeEnv) -> LinterState -> Maybe Scheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinterState -> TypeEnv
typeEnv)
        case Maybe Scheme
mScheme of
            Just Scheme
scheme -> Scheme -> LinterM Type
instantiate Scheme
scheme
            Maybe Scheme
Nothing     -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Unbound macro parameter: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
    C.LiteralExpr LiteralType
C.Int (L AlexPosn
_ LexemeClass
_ Text
txt)
        | Text
"." Text -> Text -> Bool
`Text.isInfixOf` Text
txt -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
        | Bool
otherwise -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.LiteralExpr LiteralType
C.Bool Lexeme Text
_     -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
    C.LiteralExpr LiteralType
C.Char Lexeme Text
_     -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TChar
    C.LiteralExpr LiteralType
C.String Lexeme Text
_   -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
TPointer Type
TChar
    C.LiteralExpr LiteralType
C.ConstId l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name)
        | Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"NULL" Bool -> Bool -> Bool
|| Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"nullptr" -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TNullPtr
        | Bool
otherwise -> do
            Maybe Scheme
mScheme <- (LinterState -> Maybe Scheme)
-> StateT LinterState (State [Text]) (Maybe Scheme)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Text -> TypeEnv -> Maybe Scheme
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (TypeEnv -> Maybe Scheme)
-> (LinterState -> TypeEnv) -> LinterState -> Maybe Scheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinterState -> TypeEnv
typeEnv)
            case Maybe Scheme
mScheme of
                Just Scheme
scheme -> Scheme -> LinterM Type
instantiate Scheme
scheme
                Maybe Scheme
Nothing     -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Unbound constant: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
    C.VarExpr l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name) -> do
        Maybe Scheme
mScheme <- (LinterState -> Maybe Scheme)
-> StateT LinterState (State [Text]) (Maybe Scheme)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Text -> TypeEnv -> Maybe Scheme
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (TypeEnv -> Maybe Scheme)
-> (LinterState -> TypeEnv) -> LinterState -> Maybe Scheme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LinterState -> TypeEnv
typeEnv)
        case Maybe Scheme
mScheme of
            Just Scheme
scheme -> Scheme -> LinterM Type
instantiate Scheme
scheme
            Maybe Scheme
Nothing     -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Unbound variable: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
    C.ParenExpr Node (Lexeme Text)
e -> Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
    C.UnaryExpr UnaryOp
op Node (Lexeme Text)
e -> UnaryOp -> Node (Lexeme Text) -> LinterM Type
inferUnary UnaryOp
op Node (Lexeme Text)
e
    C.BinaryExpr Node (Lexeme Text)
e1 BinaryOp
op Node (Lexeme Text)
e2 -> Node (Lexeme Text)
-> BinaryOp -> Node (Lexeme Text) -> LinterM Type
inferBinary Node (Lexeme Text)
e1 BinaryOp
op Node (Lexeme Text)
e2
    C.AssignExpr Node (Lexeme Text)
lhs AssignOp
op Node (Lexeme Text)
rhs -> do
        Type
t1 <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
lhs
        Type
t2 <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
rhs
        case (AssignOp
op, Type
t1, Type
t2) of
            (AssignOp
AopEq, Type
_, Type
_) -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
n Text
"assignment" Type
t1 Type
t2
            (AssignOp
AopPlus, TPointer Type
_, Type
TInt) -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (AssignOp
AopMinus, TPointer Type
_, Type
TInt) -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (AssignOp
AopBitXor, Type
TInt, Type
TInt) -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (AssignOp
_, Type
TInt, Type
TInt) -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            (AssignOp, Type, Type)
_ -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
n (Text -> StateT LinterState (State [Text]) ())
-> Text -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Text
"invalid assignment operation: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (AssignOp -> String
forall a. Show a => a -> String
show AssignOp
op) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with types " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
t1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
t2)
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t1
    C.TernaryExpr Node (Lexeme Text)
c Node (Lexeme Text)
t Node (Lexeme Text)
e -> do
        Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
c
        Type
t1 <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
t
        Type
t2 <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
n Text
"ternary expression" Type
t1 Type
t2
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t1
    C.FunctionCall Node (Lexeme Text)
f [Node (Lexeme Text)]
args -> do
        Type
fType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
f
        [Type]
argTypes <- (Node (Lexeme Text) -> LinterM Type)
-> [Node (Lexeme Text)] -> StateT LinterState (State [Text]) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Node (Lexeme Text) -> LinterM Type
inferExpr [Node (Lexeme Text)]
args
        Type
retType <- LinterM Type
fresh
        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
f Text
"function call" Type
fType ([Type] -> Type -> Bool -> Type
TFunc [Type]
argTypes Type
retType Bool
False)
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
retType
    C.PointerAccess Node (Lexeme Text)
e l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
member) -> do
        Type
eType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
        Type
rType <- Type -> LinterM Type
resolveType Type
eType
        case Type
rType of
            TPointer (TStruct Text
name Map Text Type
fields) ->
                case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
fields of
                    Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                    Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Struct " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
            TPointer (TUnion Text
name Map Text Type
fields) ->
                case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
fields of
                    Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                    Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Union " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
            TPointer (TUserDefined Text
name) -> do
                StructEnv
senv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
structEnv
                case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
senv of
                    Just Map Text Type
fields -> case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
fields of
                        Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                        Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Struct " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
                    Maybe (Map Text Type)
Nothing -> do
                        StructEnv
uenv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
unionEnv
                        case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
uenv of
                            Just Map Text Type
ufields -> case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
ufields of
                                Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                                Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Union " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
                            Maybe (Map Text Type)
Nothing -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
e (Text
"Accessing member of incomplete type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
            TPointer (TVar TVar
_) -> do
                Type
memberType <- LinterM Type
fresh
                let fields :: Map Text Type
fields = Text -> Type -> Map Text Type
forall k a. k -> a -> Map k a
Map.singleton Text
member Type
memberType
                Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"pointer access" (Type -> Type
TPointer (Text -> Map Text Type -> Type
TStruct Text
"unknown" Map Text Type
fields)) Type
eType
                Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
            Type
_ -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
e (Text
"Pointer access on non-pointer-to-struct type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
rType)) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
    C.MemberAccess Node (Lexeme Text)
e l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
member) -> do
        Type
eType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
        Type
rType <- Type -> LinterM Type
resolveType Type
eType
        case Type
rType of
            TStruct Text
name Map Text Type
fields ->
                case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
fields of
                    Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                    Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Struct " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
            TUnion Text
name Map Text Type
fields ->
                case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
fields of
                    Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                    Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Union " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
            TUserDefined Text
name -> do
                StructEnv
senv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
structEnv
                case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
senv of
                    Just Map Text Type
fields -> case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
fields of
                        Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                        Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Struct " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
                    Maybe (Map Text Type)
Nothing -> do
                        StructEnv
uenv <- (LinterState -> StructEnv)
-> StateT LinterState (State [Text]) StructEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> StructEnv
unionEnv
                        case Text -> StructEnv -> Maybe (Map Text Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name StructEnv
uenv of
                            Just Map Text Type
ufields -> case Text -> Map Text Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
member Map Text Type
ufields of
                                Just Type
memberType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
memberType
                                Maybe Type
Nothing -> Lexeme Text -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Lexeme Text
l (Text
"Union " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no member: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
member) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
                            Maybe (Map Text Type)
Nothing -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
e (Text
"Accessing member of incomplete type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
            Type
_ -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
e (Text
"Member access on non-struct type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Type -> String
forall a. Show a => a -> String
show Type
rType)) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh
    C.ArrayAccess Node (Lexeme Text)
e Node (Lexeme Text)
i -> do
        Type
eType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
        Type
iType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
i
        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
i Text
"array index" Type
TInt Type
iType
        case Type
eType of
            TPointer Type
elemType -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
elemType
            Type
_ -> do
                Type
elemType <- LinterM Type
fresh
                Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"array access" (Type -> Type
TPointer Type
elemType) Type
eType
                Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
elemType
    C.CastExpr Node (Lexeme Text)
ty Node (Lexeme Text)
e -> do
        Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
        Type
e_t <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"cast expression" Type
t Type
e_t
        Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t
    C.SizeofExpr Node (Lexeme Text)
_ -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.SizeofType Node (Lexeme Text)
_ -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
    C.CompoundLiteral Node (Lexeme Text)
ty Node (Lexeme Text)
_ -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
n (Text
"unhandled expression: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (NodeF (Lexeme Text) (Node (Lexeme Text)) -> String
forall a. Show a => a -> String
show NodeF (Lexeme Text) (Node (Lexeme Text))
node)) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LinterM Type
fresh

-- | Infer the type of a unary expression.
inferUnary :: UnaryOp -> Node (Lexeme Text) -> LinterM Type
inferUnary :: UnaryOp -> Node (Lexeme Text) -> LinterM Type
inferUnary UnaryOp
op Node (Lexeme Text)
e = do
    Type
t <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
    case UnaryOp
op of
        UnaryOp
UopNot     -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
e StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        UnaryOp
UopNeg     -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"negation" Type
TInt Type
t StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        UnaryOp
UopMinus   -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"unary minus" Type
TInt Type
t StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        UnaryOp
UopAddress -> Type -> Type
TPointer (Type -> Type) -> LinterM Type -> LinterM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
        UnaryOp
UopDeref   -> do
            case Type
t of
                TPointer Type
t' -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t'
                Type
_           -> do
                    Type
ptrType <- LinterM Type
fresh
                    Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"dereference" (Type -> Type
TPointer Type
ptrType) Type
t
                    Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ptrType
        UnaryOp
UopIncr    -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"increment" Type
TInt Type
t StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        UnaryOp
UopDecr    -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e Text
"decrement" Type
TInt Type
t StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt

-- | Infer the type of a binary expression.
inferBinary :: Node (Lexeme Text) -> BinaryOp -> Node (Lexeme Text) -> LinterM Type
inferBinary :: Node (Lexeme Text)
-> BinaryOp -> Node (Lexeme Text) -> LinterM Type
inferBinary Node (Lexeme Text)
e1 BinaryOp
op Node (Lexeme Text)
e2 = do
    Type
t1 <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e1
    Type
t2 <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e2
    let opCtx :: Text
opCtx = Text
"binary operator " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (BinaryOp -> String
forall a. Show a => a -> String
show BinaryOp
op)
    case BinaryOp
op of
        BinaryOp
BopPlus -> case (Type
t1, Type
t2) of
            (TPointer Type
pt, Type
TInt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
TPointer Type
pt
            (Type
TInt, TPointer Type
pt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
TPointer Type
pt
            (Type
TInt, Type
TInt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
            (Type
TFloat, Type
TFloat) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
            (Type
TInt, Type
TFloat) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
            (Type
TFloat, Type
TInt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
            (Type, Type)
v -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
e1 (Text
"invalid operands for +: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack ((Type, Type) -> String
forall a. Show a => a -> String
show (Type, Type)
v)) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopMinus -> case (Type
t1, Type
t2) of
            (TPointer Type
pt, Type
TInt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> LinterM Type) -> Type -> LinterM Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
TPointer Type
pt
            (TPointer Type
pt1, TPointer Type
pt2) -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
pt1 Type
pt2 StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
            (Type
TInt, Type
TInt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
            (Type
TFloat, Type
TFloat) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
            (Type
TInt, Type
TFloat) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
            (Type
TFloat, Type
TInt) -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TFloat
            (Type, Type)
v -> Node (Lexeme Text) -> Text -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> StateT LinterState (State [Text]) ()
addError Node (Lexeme Text)
e1 (Text
"invalid operands for -: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack ((Type, Type) -> String
forall a. Show a => a -> String
show (Type, Type)
v)) StateT LinterState (State [Text]) ()
-> LinterM Type -> LinterM Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopMul -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopDiv -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopMod -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopBitAnd -> do
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
            Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopBitOr -> do
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
            Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopBitXor -> do
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
            Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopLsh -> do
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
            Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopRsh -> do
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
TInt Type
t1
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e2 Text
opCtx Type
TInt Type
t2
            Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TInt
        BinaryOp
BopEq -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
t1 Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopNe -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
t1 Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopLt -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
t1 Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopLe -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
t1 Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopGt -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
t1 Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopGe -> do
           Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e1 Text
opCtx Type
t1 Type
t2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopAnd -> do
           Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
e1
           Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
e2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool
        BinaryOp
BopOr -> do
           Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
e1
           Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
e2
           Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
TBool

-- | Check if an expression is a valid condition.
checkCond :: Node (Lexeme Text) -> LinterM ()
checkCond :: Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond = do
    Type
condType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
cond
    Subst
s <- (LinterState -> Subst) -> StateT LinterState (State [Text]) Subst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Subst
subst
    let condType' :: Type
condType' = Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
condType
    case Type
condType' of
        Type
TBool      -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Type
TInt       -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        TPointer Type
_ -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Type
_          -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
cond Text
"condition" Type
TBool Type
condType'

-- | Type check a list of statements.
checkStmts :: [Node (Lexeme Text)] -> Type -> LinterM ()
checkStmts :: [Node (Lexeme Text)]
-> Type -> StateT LinterState (State [Text]) ()
checkStmts [] Type
_ = () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkStmts ((Fix (C.VarDeclStmt (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
declSpecArrays)) Maybe (Node (Lexeme Text))
mInit)):[Node (Lexeme Text)]
stmts) Type
expectedRetType = do
    Type
varType <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
    let finalVarType :: Type
finalVarType = (Node (Lexeme Text) -> Type -> Type)
-> Type -> [Node (Lexeme Text)] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
_ Type
acc -> Type -> Type
TPointer Type
acc) Type
varType [Node (Lexeme Text)]
declSpecArrays
    case Maybe (Node (Lexeme Text))
mInit of
        Just initExpr :: Node (Lexeme Text)
initExpr@(Fix (C.InitialiserList [Node (Lexeme Text)]
es)) -> do
            Type
rVarType <- Type -> LinterM Type
resolveType Type
finalVarType
            case Type
rVarType of
                TStruct Text
_ Map Text Type
fields -> do
                    let fieldTypes :: [Type]
fieldTypes = Map Text Type -> [Type]
forall k a. Map k a -> [a]
Map.elems Map Text Type
fields
                    Bool
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
fieldTypes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Node (Lexeme Text)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node (Lexeme Text)]
es) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$
                        (Type
 -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> [Type]
-> [Node (Lexeme Text)]
-> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\Type
fieldType Node (Lexeme Text)
e -> do
                            Type
eType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
                            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
e (Text
"initialisation of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Type
fieldType Type
eType
                        ) [Type]
fieldTypes [Node (Lexeme Text)]
es
                Type
_ -> do
                    Type
initType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
initExpr
                    Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
initExpr (Text
"initialisation of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Type
finalVarType Type
initType
        Maybe (Node (Lexeme Text))
_ -> Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Node (Lexeme Text))
mInit ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
initExpr -> do
            Type
initType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
initExpr
            Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
initExpr (Text
"initialisation of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Type
finalVarType Type
initType

    let scheme :: Scheme
scheme = [TVar] -> Type -> Scheme
Forall [] Type
finalVarType
    (TypeEnv -> TypeEnv)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a. (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv (Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Scheme
scheme) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ [Node (Lexeme Text)]
-> Type -> StateT LinterState (State [Text]) ()
checkStmts [Node (Lexeme Text)]
stmts Type
expectedRetType
checkStmts ((Fix (C.VLA Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) Node (Lexeme Text)
sizeExpr)):[Node (Lexeme Text)]
stmts) Type
expectedRetType = do
    Type
baseType <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
    let varType :: Type
varType = Type -> Type
TPointer Type
baseType
    Type
sizeType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
sizeExpr
    Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
sizeExpr Text
"VLA size" Type
TInt Type
sizeType
    let scheme :: Scheme
scheme = [TVar] -> Type -> Scheme
Forall [] Type
varType
    (TypeEnv -> TypeEnv)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a. (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv (Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Scheme
scheme) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ [Node (Lexeme Text)]
-> Type -> StateT LinterState (State [Text]) ()
checkStmts [Node (Lexeme Text)]
stmts Type
expectedRetType
checkStmts (Node (Lexeme Text)
stmt:[Node (Lexeme Text)]
stmts) Type
expectedRetType = do
    Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
stmt Type
expectedRetType StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Node (Lexeme Text)]
-> Type -> StateT LinterState (State [Text]) ()
checkStmts [Node (Lexeme Text)]
stmts Type
expectedRetType

-- | Type check a single statement.
checkStmt :: Node (Lexeme Text) -> Type -> LinterM ()
checkStmt :: Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt n :: Node (Lexeme Text)
n@(Fix NodeF (Lexeme Text) (Node (Lexeme Text))
node) Type
expectedRetType = case NodeF (Lexeme Text) (Node (Lexeme Text))
node of
    C.CompoundStmt [Node (Lexeme Text)]
stmts -> [Node (Lexeme Text)]
-> Type -> StateT LinterState (State [Text]) ()
checkStmts [Node (Lexeme Text)]
stmts Type
expectedRetType
    C.Return (Just Node (Lexeme Text)
expr) -> do
        Type
actualRetType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
expr
        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
expr Text
"return value" Type
expectedRetType Type
actualRetType
    C.Return Maybe (Node (Lexeme Text))
Nothing -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
n Text
"return from void function" Type
expectedRetType Type
TUnit
    C.IfStmt Node (Lexeme Text)
cond Node (Lexeme Text)
thenB Maybe (Node (Lexeme Text))
mElseB -> do
        Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond
        Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
thenB Type
expectedRetType
        StateT LinterState (State [Text]) ()
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> Maybe (Node (Lexeme Text))
-> StateT LinterState (State [Text]) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
`checkStmt` Type
expectedRetType) Maybe (Node (Lexeme Text))
mElseB
    C.WhileStmt Node (Lexeme Text)
cond Node (Lexeme Text)
body -> do
        Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond
        Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
    C.ForStmt Node (Lexeme Text)
init' Node (Lexeme Text)
cond Node (Lexeme Text)
next Node (Lexeme Text)
body -> do
        (TypeEnv -> TypeEnv)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a. (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv TypeEnv -> TypeEnv
forall a. a -> a
id (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ do
            case Node (Lexeme Text)
init' of
                Fix (C.VarDeclStmt (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
_)) Maybe (Node (Lexeme Text))
mInit) -> do
                    Type
varType <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                    Maybe (Node (Lexeme Text))
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Node (Lexeme Text))
mInit ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
initExpr -> do
                        Type
initType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
initExpr
                        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
initExpr (Text
"for loop initialisation of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Type
varType Type
initType
                    TypeEnv
env <- (LinterState -> TypeEnv)
-> StateT LinterState (State [Text]) TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> TypeEnv
typeEnv
                    Scheme
scheme <- TypeEnv -> Type -> LinterM Scheme
generalize TypeEnv
env Type
varType
                    (TypeEnv -> TypeEnv)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a. (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv (Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Scheme
scheme) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ do
                        Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond
                        LinterM Type -> StateT LinterState (State [Text]) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LinterM Type -> StateT LinterState (State [Text]) ())
-> LinterM Type -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
next
                        Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
                Node (Lexeme Text)
_ -> do
                    LinterM Type -> StateT LinterState (State [Text]) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LinterM Type -> StateT LinterState (State [Text]) ())
-> LinterM Type -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
init'
                    Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond
                    LinterM Type -> StateT LinterState (State [Text]) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LinterM Type -> StateT LinterState (State [Text]) ())
-> LinterM Type -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
next
                    Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
    C.DoWhileStmt Node (Lexeme Text)
body Node (Lexeme Text)
cond -> do
        Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
        Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
checkCond Node (Lexeme Text)
cond
    C.SwitchStmt Node (Lexeme Text)
expr [Node (Lexeme Text)]
cases -> do
        Type
exprType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
expr
        Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
expr Text
"switch expression" Type
TInt Type
exprType StateT LinterState (State [Text]) ()
-> (Text -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a. LinterM a -> (Text -> LinterM a) -> LinterM a
`catchError` \Text
_ -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
expr Text
"switch expression" Type
exprType Type
exprType
        [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node (Lexeme Text)]
cases ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \case
            Fix (C.Case Node (Lexeme Text)
caseExpr Node (Lexeme Text)
body) -> do
                Type
caseExprType <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
caseExpr
                Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
caseExpr Text
"case expression" Type
TInt Type
caseExprType StateT LinterState (State [Text]) ()
-> (Text -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a. LinterM a -> (Text -> LinterM a) -> LinterM a
`catchError` \Text
_ -> Node (Lexeme Text)
-> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
forall a.
HasLocation a =>
a -> Text -> Type -> Type -> StateT LinterState (State [Text]) ()
unify Node (Lexeme Text)
caseExpr Text
"case expression" Type
exprType Type
caseExprType
                Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
            Fix (C.Default Node (Lexeme Text)
body) -> Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
            Node (Lexeme Text)
_ -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    C.ExprStmt Node (Lexeme Text)
e -> LinterM Type -> StateT LinterState (State [Text]) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LinterM Type -> StateT LinterState (State [Text]) ())
-> LinterM Type -> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
e
    NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Analysis Passes

type TranslationUnit = (FilePath, [Node (Lexeme Text)])

-- | Collect all global definitions (structs, typedefs, functions) in a file.
collectGlobals :: TranslationUnit -> LinterM ()
collectGlobals :: TranslationUnit -> StateT LinterState (State [Text]) ()
collectGlobals (String
file, [Node (Lexeme Text)]
nodes) = do
    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { currentFile :: String
currentFile = String
file }
    AstActions (StateT LinterState (State [Text])) Text
-> TranslationUnit -> StateT LinterState (State [Text]) ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT LinterState (State [Text])) Text
collector (String
file, [Node (Lexeme Text)]
nodes)
  where
    handleEnumerator :: Type -> Node (Lexeme Text) -> LinterM ()
    handleEnumerator :: Type -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
handleEnumerator Type
enumType (Fix (C.Enumerator (L AlexPosn
_ LexemeClass
_ Text
ename) Maybe (Node (Lexeme Text))
_)) = do
        let scheme :: Scheme
scheme = [TVar] -> Type -> Scheme
Forall [] Type
enumType
        (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typeEnv :: TypeEnv
typeEnv = Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
ename Scheme
scheme (LinterState -> TypeEnv
typeEnv LinterState
s) }
    handleEnumerator Type
enumType (Fix (C.Commented Node (Lexeme Text)
_ Node (Lexeme Text)
n)) = Type -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
handleEnumerator Type
enumType Node (Lexeme Text)
n
    handleEnumerator Type
_ Node (Lexeme Text)
_ = () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    collector :: AstActions (StateT LinterState (State [Text])) Text
collector = AstActions (StateT LinterState (State [Text])) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: String
-> Node (Lexeme Text)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
doNode = \String
_ Node (Lexeme Text)
node StateT LinterState (State [Text]) ()
continuation -> do
            case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
                C.AggregateDecl (Fix (C.Struct (L AlexPosn
_ LexemeClass
_ Text
sname) [Node (Lexeme Text)]
members)) -> do
                    [(Text, Type)]
memberDecls <- ([[(Text, Type)]] -> [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
-> StateT LinterState (State [Text]) [(Text, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Text, Type)]] -> [(Text, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (StateT LinterState (State [Text]) [[(Text, Type)]]
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> ((Node (Lexeme Text)
     -> StateT LinterState (State [Text]) [(Text, Type)])
    -> StateT LinterState (State [Text]) [[(Text, Type)]])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme Text)]
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme Text)]
members ((Node (Lexeme Text)
  -> StateT LinterState (State [Text]) [(Text, Type)])
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ \case
                        Fix (C.MemberDecl (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
mname) [Node (Lexeme Text)]
declSpecArrays)) Maybe (Lexeme Text)
_) -> do
                            Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                            let finalT :: Type
finalT = (Node (Lexeme Text) -> Type -> Type)
-> Type -> [Node (Lexeme Text)] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
_ Type
acc -> Type -> Type
TPointer Type
acc) Type
t [Node (Lexeme Text)]
declSpecArrays
                            [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text
mname, Type
finalT)]
                        Node (Lexeme Text)
_ -> [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    let fieldEnv :: Map Text Type
fieldEnv = [(Text, Type)] -> Map Text Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Type)]
memberDecls
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { structEnv :: StructEnv
structEnv = Text -> Map Text Type -> StructEnv -> StructEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
sname Map Text Type
fieldEnv (LinterState -> StructEnv
structEnv LinterState
s) }
                C.AggregateDecl (Fix (C.Union (L AlexPosn
_ LexemeClass
_ Text
uname) [Node (Lexeme Text)]
members)) -> do
                    [(Text, Type)]
memberDecls <- ([[(Text, Type)]] -> [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
-> StateT LinterState (State [Text]) [(Text, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Text, Type)]] -> [(Text, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (StateT LinterState (State [Text]) [[(Text, Type)]]
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> ((Node (Lexeme Text)
     -> StateT LinterState (State [Text]) [(Text, Type)])
    -> StateT LinterState (State [Text]) [[(Text, Type)]])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme Text)]
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme Text)]
members ((Node (Lexeme Text)
  -> StateT LinterState (State [Text]) [(Text, Type)])
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ \case
                        Fix (C.MemberDecl (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
mname) [Node (Lexeme Text)]
declSpecArrays)) Maybe (Lexeme Text)
_) -> do
                            Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                            let finalT :: Type
finalT = (Node (Lexeme Text) -> Type -> Type)
-> Type -> [Node (Lexeme Text)] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
_ Type
acc -> Type -> Type
TPointer Type
acc) Type
t [Node (Lexeme Text)]
declSpecArrays
                            [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text
mname, Type
finalT)]
                        Node (Lexeme Text)
_ -> [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    let fieldEnv :: Map Text Type
fieldEnv = [(Text, Type)] -> Map Text Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Type)]
memberDecls
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { unionEnv :: StructEnv
unionEnv = Text -> Map Text Type -> StructEnv -> StructEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
uname Map Text Type
fieldEnv (LinterState -> StructEnv
unionEnv LinterState
s) }
                C.Typedef (Fix (C.Struct (L AlexPosn
_ LexemeClass
_ Text
sname) [Node (Lexeme Text)]
members)) (L AlexPosn
_ LexemeClass
_ Text
tname) -> do
                    [(Text, Type)]
memberDecls <- ([[(Text, Type)]] -> [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
-> StateT LinterState (State [Text]) [(Text, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Text, Type)]] -> [(Text, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (StateT LinterState (State [Text]) [[(Text, Type)]]
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> ((Node (Lexeme Text)
     -> StateT LinterState (State [Text]) [(Text, Type)])
    -> StateT LinterState (State [Text]) [[(Text, Type)]])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme Text)]
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme Text)]
members ((Node (Lexeme Text)
  -> StateT LinterState (State [Text]) [(Text, Type)])
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ \case
                        Fix (C.MemberDecl (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
mname) [Node (Lexeme Text)]
declSpecArrays)) Maybe (Lexeme Text)
_) -> do
                            Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                            let finalT :: Type
finalT = (Node (Lexeme Text) -> Type -> Type)
-> Type -> [Node (Lexeme Text)] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
_ Type
acc -> Type -> Type
TPointer Type
acc) Type
t [Node (Lexeme Text)]
declSpecArrays
                            [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text
mname, Type
finalT)]
                        Node (Lexeme Text)
_ -> [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    let fieldEnv :: Map Text Type
fieldEnv = [(Text, Type)] -> Map Text Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Type)]
memberDecls
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { structEnv :: StructEnv
structEnv = Text -> Map Text Type -> StructEnv -> StructEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
sname Map Text Type
fieldEnv (LinterState -> StructEnv
structEnv LinterState
s) }
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typedefEnv :: Map Text Type
typedefEnv = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
tname (Text -> Map Text Type -> Type
TStruct Text
sname Map Text Type
fieldEnv) (LinterState -> Map Text Type
typedefEnv LinterState
s) }
                C.Typedef (Fix (C.Union (L AlexPosn
_ LexemeClass
_ Text
uname) [Node (Lexeme Text)]
members)) (L AlexPosn
_ LexemeClass
_ Text
tname) -> do
                    [(Text, Type)]
memberDecls <- ([[(Text, Type)]] -> [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
-> StateT LinterState (State [Text]) [(Text, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(Text, Type)]] -> [(Text, Type)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (StateT LinterState (State [Text]) [[(Text, Type)]]
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> ((Node (Lexeme Text)
     -> StateT LinterState (State [Text]) [(Text, Type)])
    -> StateT LinterState (State [Text]) [[(Text, Type)]])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node (Lexeme Text)]
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [[(Text, Type)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme Text)]
members ((Node (Lexeme Text)
  -> StateT LinterState (State [Text]) [(Text, Type)])
 -> StateT LinterState (State [Text]) [(Text, Type)])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) [(Text, Type)])
-> StateT LinterState (State [Text]) [(Text, Type)]
forall a b. (a -> b) -> a -> b
$ \case
                        Fix (C.MemberDecl (Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
mname) [Node (Lexeme Text)]
declSpecArrays)) Maybe (Lexeme Text)
_) -> do
                            Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                            let finalT :: Type
finalT = (Node (Lexeme Text) -> Type -> Type)
-> Type -> [Node (Lexeme Text)] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
_ Type
acc -> Type -> Type
TPointer Type
acc) Type
t [Node (Lexeme Text)]
declSpecArrays
                            [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Text
mname, Type
finalT)]
                        Node (Lexeme Text)
_ -> [(Text, Type)] -> StateT LinterState (State [Text]) [(Text, Type)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    let fieldEnv :: Map Text Type
fieldEnv = [(Text, Type)] -> Map Text Type
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text, Type)]
memberDecls
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { unionEnv :: StructEnv
unionEnv = Text -> Map Text Type -> StructEnv -> StructEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
uname Map Text Type
fieldEnv (LinterState -> StructEnv
unionEnv LinterState
s) }
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typedefEnv :: Map Text Type
typedefEnv = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
tname (Text -> Map Text Type -> Type
TUnion Text
uname Map Text Type
fieldEnv) (LinterState -> Map Text Type
typedefEnv LinterState
s) }
                C.Typedef (Fix (C.EnumDecl Lexeme Text
_ [Node (Lexeme Text)]
enumerators (L AlexPosn
_ LexemeClass
_ Text
tname))) (L AlexPosn
_ LexemeClass
_ Text
_) -> do
                    let enumType :: Type
enumType = Type
TInt
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typedefEnv :: Map Text Type
typedefEnv = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
tname Type
enumType (LinterState -> Map Text Type
typedefEnv LinterState
s) }
                    [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node (Lexeme Text)]
enumerators ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
e -> Type -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
handleEnumerator Type
enumType Node (Lexeme Text)
e
                C.TypedefFunction (Fix (C.FunctionPrototype Node (Lexeme Text)
retType (L AlexPosn
_ LexemeClass
_ Text
tname) [Node (Lexeme Text)]
params)) -> do
                    Type
ret_t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
retType
                    let (Bool
isVariadic, [Node (Lexeme Text)]
filteredParams) = case [Node (Lexeme Text)]
params of
                            [] -> (Bool
False, [])
                            [Node (Lexeme Text)]
ps -> let lastParam :: Node (Lexeme Text)
lastParam = [Node (Lexeme Text)] -> Node (Lexeme Text)
forall a. [a] -> a
last [Node (Lexeme Text)]
ps
                                  in case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
lastParam of
                                      NodeF (Lexeme Text) (Node (Lexeme Text))
C.Ellipsis -> (Bool
True, [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a]
init [Node (Lexeme Text)]
ps)
                                      NodeF (Lexeme Text) (Node (Lexeme Text))
_          -> (Bool
False, [Node (Lexeme Text)]
ps)
                    [Type]
param_ts <- [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Node (Lexeme Text) -> Bool)
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Node (Lexeme Text) -> Bool) -> Node (Lexeme Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Bool
isVoidParam) [Node (Lexeme Text)]
filteredParams) ((Node (Lexeme Text) -> LinterM Type)
 -> StateT LinterState (State [Text]) [Type])
-> (Node (Lexeme Text) -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall a b. (a -> b) -> a -> b
$ \case
                        Fix (C.VarDecl Node (Lexeme Text)
ty Lexeme Text
_ [Node (Lexeme Text)]
_) -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                        Node (Lexeme Text)
_                      -> LinterM Type
fresh
                    let ftype :: Type
ftype = [Type] -> Type -> Bool -> Type
TFunc [Type]
param_ts Type
ret_t Bool
isVariadic
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typedefEnv :: Map Text Type
typedefEnv = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
tname Type
ftype (LinterState -> Map Text Type
typedefEnv LinterState
s) }
                C.Typedef Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) -> do
                    Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typedefEnv :: Map Text Type
typedefEnv = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Type
t (LinterState -> Map Text Type
typedefEnv LinterState
s) }
                C.EnumDecl Lexeme Text
_ [Node (Lexeme Text)]
enumerators (L AlexPosn
_ LexemeClass
_ Text
name) -> do
                    let enumType :: Type
enumType = Type
TInt
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typedefEnv :: Map Text Type
typedefEnv = Text -> Type -> Map Text Type -> Map Text Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Type
enumType (LinterState -> Map Text Type
typedefEnv LinterState
s) }
                    [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node (Lexeme Text)]
enumerators ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
e -> Type -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
handleEnumerator Type
enumType Node (Lexeme Text)
e
                C.EnumConsts Maybe (Lexeme Text)
maybe_name [Node (Lexeme Text)]
enumerators -> do
                    let enumType :: Type
enumType = Type
TInt -- Anonymous enums are compatible with int.
                    Maybe (Lexeme Text)
-> (Lexeme Text -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Lexeme Text)
maybe_name ((Lexeme Text -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Lexeme Text -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \(L AlexPosn
_ LexemeClass
_ Text
name) -> do
                        let scheme :: Scheme
scheme = [TVar] -> Type -> Scheme
Forall [] Type
enumType
                        (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typeEnv :: TypeEnv
typeEnv = Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Scheme
scheme (LinterState -> TypeEnv
typeEnv LinterState
s) }
                    [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Node (Lexeme Text)]
enumerators ((Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
 -> StateT LinterState (State [Text]) ())
-> (Node (Lexeme Text) -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
e -> Type -> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
handleEnumerator Type
enumType Node (Lexeme Text)
e
                C.FunctionDecl Scope
_ (Fix (C.FunctionPrototype Node (Lexeme Text)
retType Lexeme Text
name [Node (Lexeme Text)]
params)) ->
                    Lexeme Text
-> Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> StateT LinterState (State [Text]) ()
addFuncSig Lexeme Text
name Node (Lexeme Text)
retType [Node (Lexeme Text)]
params
                C.FunctionDefn Scope
_ (Fix (C.FunctionPrototype Node (Lexeme Text)
retType Lexeme Text
name [Node (Lexeme Text)]
params)) Node (Lexeme Text)
_ ->
                    Lexeme Text
-> Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> StateT LinterState (State [Text]) ()
addFuncSig Lexeme Text
name Node (Lexeme Text)
retType [Node (Lexeme Text)]
params
                C.PreprocDefineConst (L AlexPosn
_ LexemeClass
_ Text
name) Node (Lexeme Text)
valNode -> do
                    Type
ty <- Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
valNode LinterM Type -> (Text -> LinterM Type) -> LinterM Type
forall a. LinterM a -> (Text -> LinterM a) -> LinterM a
`catchError` \Text
_ -> LinterM Type
fresh
                    TypeEnv
env <- (LinterState -> TypeEnv)
-> StateT LinterState (State [Text]) TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> TypeEnv
typeEnv
                    Scheme
scheme <- TypeEnv -> Type -> LinterM Scheme
generalize TypeEnv
env Type
ty
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typeEnv :: TypeEnv
typeEnv = Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Scheme
scheme (LinterState -> TypeEnv
typeEnv LinterState
s) }
                C.PreprocDefineMacro (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
params Node (Lexeme Text)
body -> do
                    [Type]
paramTypes <- [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Node (Lexeme Text)]
params ((Node (Lexeme Text) -> LinterM Type)
 -> StateT LinterState (State [Text]) [Type])
-> (Node (Lexeme Text) -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall a b. (a -> b) -> a -> b
$ \Node (Lexeme Text)
_ -> LinterM Type
fresh
                    let getParamName :: Fix (NodeF (Lexeme a)) -> Maybe a
getParamName (Fix (C.MacroParam (L AlexPosn
_ LexemeClass
_ a
n))) = a -> Maybe a
forall a. a -> Maybe a
Just a
n
                        getParamName Fix (NodeF (Lexeme a))
_                              = Maybe a
forall a. Maybe a
Nothing
                    let paramNames :: [Text]
paramNames = (Node (Lexeme Text) -> Maybe Text)
-> [Node (Lexeme Text)] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme Text) -> Maybe Text
forall a. Fix (NodeF (Lexeme a)) -> Maybe a
getParamName [Node (Lexeme Text)]
params
                    let paramSchemes :: [Scheme]
paramSchemes = (Type -> Scheme) -> [Type] -> [Scheme]
forall a b. (a -> b) -> [a] -> [b]
map ([TVar] -> Type -> Scheme
Forall []) [Type]
paramTypes
                    let paramEnv :: TypeEnv
paramEnv = [(Text, Scheme)] -> TypeEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Scheme)] -> TypeEnv) -> [(Text, Scheme)] -> TypeEnv
forall a b. (a -> b) -> a -> b
$ [Text] -> [Scheme] -> [(Text, Scheme)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
paramNames [Scheme]
paramSchemes

                    Type
vaType <- LinterM Type
fresh
                    let vaEnv :: TypeEnv
vaEnv = Text -> Scheme -> TypeEnv
forall k a. k -> a -> Map k a
Map.singleton Text
"__VA_ARGS__" ([TVar] -> Type -> Scheme
Forall [] Type
vaType)

                    Type
bodyType <- (TypeEnv -> TypeEnv) -> LinterM Type -> LinterM Type
forall a. (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv (TypeEnv -> TypeEnv -> TypeEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union TypeEnv
paramEnv (TypeEnv -> TypeEnv) -> (TypeEnv -> TypeEnv) -> TypeEnv -> TypeEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeEnv -> TypeEnv -> TypeEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union TypeEnv
vaEnv) (Node (Lexeme Text) -> LinterM Type
inferExpr Node (Lexeme Text)
body)

                    Subst
s <- (LinterState -> Subst) -> StateT LinterState (State [Text]) Subst
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> Subst
subst
                    [Type]
finalParamTypes <- [Type]
-> (Type -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Type]
paramTypes ((Type -> LinterM Type)
 -> StateT LinterState (State [Text]) [Type])
-> (Type -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall a b. (a -> b) -> a -> b
$ \Type
pt -> Type -> LinterM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Subst -> Type -> Type
forall a. Substitutable a => Subst -> a -> a
apply Subst
s Type
pt)

                    let funcType :: Type
funcType = [Type] -> Type -> Bool -> Type
TFunc [Type]
finalParamTypes Type
bodyType Bool
True
                    TypeEnv
env <- (LinterState -> TypeEnv)
-> StateT LinterState (State [Text]) TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> TypeEnv
typeEnv
                    Scheme
scheme <- TypeEnv -> Type -> LinterM Scheme
generalize TypeEnv
env Type
funcType
                    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
st -> LinterState
st { typeEnv :: TypeEnv
typeEnv = Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Scheme
scheme (LinterState -> TypeEnv
typeEnv LinterState
st) }
                NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            StateT LinterState (State [Text]) ()
continuation
        }

    addFuncSig :: Lexeme Text
-> Node (Lexeme Text)
-> [Node (Lexeme Text)]
-> StateT LinterState (State [Text]) ()
addFuncSig Lexeme Text
name Node (Lexeme Text)
retType [Node (Lexeme Text)]
params = do
        Type
ret_t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
retType
        let (Bool
isVariadic, [Node (Lexeme Text)]
filteredParams) = case [Node (Lexeme Text)]
params of
                [] -> (Bool
False, [])
                [Node (Lexeme Text)]
ps -> let lastParam :: Node (Lexeme Text)
lastParam = [Node (Lexeme Text)] -> Node (Lexeme Text)
forall a. [a] -> a
last [Node (Lexeme Text)]
ps
                      in case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
lastParam of
                          NodeF (Lexeme Text) (Node (Lexeme Text))
C.Ellipsis -> (Bool
True, [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a]
init [Node (Lexeme Text)]
ps)
                          NodeF (Lexeme Text) (Node (Lexeme Text))
_          -> (Bool
False, [Node (Lexeme Text)]
ps)
        [Type]
param_ts <- [Node (Lexeme Text)]
-> (Node (Lexeme Text) -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Node (Lexeme Text) -> Bool)
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Node (Lexeme Text) -> Bool) -> Node (Lexeme Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Bool
isVoidParam) [Node (Lexeme Text)]
filteredParams) ((Node (Lexeme Text) -> LinterM Type)
 -> StateT LinterState (State [Text]) [Type])
-> (Node (Lexeme Text) -> LinterM Type)
-> StateT LinterState (State [Text]) [Type]
forall a b. (a -> b) -> a -> b
$ \case
            Fix (C.VarDecl Node (Lexeme Text)
ty Lexeme Text
_ [Node (Lexeme Text)]
_) -> Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
            Node (Lexeme Text)
_                      -> LinterM Type
fresh
        let ftype :: Type
ftype = [Type] -> Type -> Bool -> Type
TFunc [Type]
param_ts Type
ret_t Bool
isVariadic
        TypeEnv
env <- (LinterState -> TypeEnv)
-> StateT LinterState (State [Text]) TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets LinterState -> TypeEnv
typeEnv
        Scheme
scheme <- TypeEnv -> Type -> LinterM Scheme
generalize TypeEnv
env Type
ftype
        (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { typeEnv :: TypeEnv
typeEnv = Text -> Scheme -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name) Scheme
scheme (LinterState -> TypeEnv
typeEnv LinterState
s) }

-- | Type check a file.
typeCheckFile :: TranslationUnit -> LinterM ()
typeCheckFile :: TranslationUnit -> StateT LinterState (State [Text]) ()
typeCheckFile (String
file, [Node (Lexeme Text)]
nodes) = do
    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { currentFile :: String
currentFile = String
file }
    AstActions (StateT LinterState (State [Text])) Text
-> TranslationUnit -> StateT LinterState (State [Text]) ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (StateT LinterState (State [Text])) Text
collector (String
file, [Node (Lexeme Text)]
nodes)
  where
    collector :: AstActions (StateT LinterState (State [Text])) Text
collector = AstActions (StateT LinterState (State [Text])) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
        { doNode :: String
-> Node (Lexeme Text)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
doNode = \String
_ Node (Lexeme Text)
node StateT LinterState (State [Text]) ()
continuation -> do
            case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
                C.FunctionDefn Scope
_ Node (Lexeme Text)
proto Node (Lexeme Text)
body -> Node (Lexeme Text)
-> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
typeCheckFunc Node (Lexeme Text)
proto Node (Lexeme Text)
body
                NodeF (Lexeme Text) (Node (Lexeme Text))
_                           -> () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            StateT LinterState (State [Text]) ()
continuation
        }

isVoidParam :: Node (Lexeme Text) -> Bool
isVoidParam :: Node (Lexeme Text) -> Bool
isVoidParam (Fix (C.VarDecl Node (Lexeme Text)
ty Lexeme Text
_ [Node (Lexeme Text)]
_)) = Node (Lexeme Text) -> Bool
isVoidType Node (Lexeme Text)
ty
isVoidParam Node (Lexeme Text)
node                     = Node (Lexeme Text) -> Bool
isVoidType Node (Lexeme Text)
node

isVoidType :: Node (Lexeme Text) -> Bool
isVoidType :: Node (Lexeme Text) -> Bool
isVoidType (Fix (C.TyStd (L AlexPosn
_ LexemeClass
_ Text
"void"))) = Bool
True
isVoidType (Fix (C.TyConst Node (Lexeme Text)
t))            = Node (Lexeme Text) -> Bool
isVoidType Node (Lexeme Text)
t
isVoidType (Fix (C.TyOwner Node (Lexeme Text)
t))            = Node (Lexeme Text) -> Bool
isVoidType Node (Lexeme Text)
t
isVoidType (Fix (C.TyNullable Node (Lexeme Text)
t))         = Node (Lexeme Text) -> Bool
isVoidType Node (Lexeme Text)
t
isVoidType (Fix (C.TyNonnull Node (Lexeme Text)
t))          = Node (Lexeme Text) -> Bool
isVoidType Node (Lexeme Text)
t
isVoidType Node (Lexeme Text)
_                              = Bool
False

-- | Type check a function.
typeCheckFunc :: Node (Lexeme Text) -> Node (Lexeme Text) -> LinterM ()
typeCheckFunc :: Node (Lexeme Text)
-> Node (Lexeme Text) -> StateT LinterState (State [Text]) ()
typeCheckFunc (Fix (C.FunctionPrototype Node (Lexeme Text)
retType (L AlexPosn
_ LexemeClass
_ Text
_) [Node (Lexeme Text)]
params)) Node (Lexeme Text)
body = do
    (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LinterState -> LinterState)
 -> StateT LinterState (State [Text]) ())
-> (LinterState -> LinterState)
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ \LinterState
s -> LinterState
s { subst :: Subst
subst = Subst
forall k a. Map k a
Map.empty }
    Type
expectedRetType <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
retType
    [(Text, Scheme)]
paramSchemes <- [Node (Lexeme Text)]
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) (Text, Scheme))
-> StateT LinterState (State [Text]) [(Text, Scheme)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((Node (Lexeme Text) -> Bool)
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Node (Lexeme Text) -> Bool) -> Node (Lexeme Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node (Lexeme Text) -> Bool
isVoidParam) [Node (Lexeme Text)]
params) ((Node (Lexeme Text)
  -> StateT LinterState (State [Text]) (Text, Scheme))
 -> StateT LinterState (State [Text]) [(Text, Scheme)])
-> (Node (Lexeme Text)
    -> StateT LinterState (State [Text]) (Text, Scheme))
-> StateT LinterState (State [Text]) [(Text, Scheme)]
forall a b. (a -> b) -> a -> b
$ \case
        Fix (C.VarDecl Node (Lexeme Text)
ty (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
declSpecArrays) -> do
            Type
t <- Node (Lexeme Text) -> LinterM Type
cimpleToType Node (Lexeme Text)
ty
            let finalT :: Type
finalT = (Node (Lexeme Text) -> Type -> Type)
-> Type -> [Node (Lexeme Text)] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Node (Lexeme Text)
_ Type
acc -> Type -> Type
TPointer Type
acc) Type
t [Node (Lexeme Text)]
declSpecArrays
            (Text, Scheme) -> StateT LinterState (State [Text]) (Text, Scheme)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
name, [TVar] -> Type -> Scheme
Forall [] Type
finalT)
        Node (Lexeme Text)
_ -> (Text, Scheme) -> StateT LinterState (State [Text]) (Text, Scheme)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"", [TVar] -> Type -> Scheme
Forall [] Type
TUnit)
    let paramEnv :: TypeEnv
paramEnv = [(Text, Scheme)] -> TypeEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Scheme)] -> TypeEnv) -> [(Text, Scheme)] -> TypeEnv
forall a b. (a -> b) -> a -> b
$ ((Text, Scheme) -> Bool) -> [(Text, Scheme)] -> [(Text, Scheme)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Text, Scheme) -> Bool) -> (Text, Scheme) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null (Text -> Bool)
-> ((Text, Scheme) -> Text) -> (Text, Scheme) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Scheme) -> Text
forall a b. (a, b) -> a
fst) [(Text, Scheme)]
paramSchemes
    (TypeEnv -> TypeEnv)
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a. (TypeEnv -> TypeEnv) -> LinterM a -> LinterM a
withEnv (TypeEnv -> TypeEnv -> TypeEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union TypeEnv
paramEnv) (StateT LinterState (State [Text]) ()
 -> StateT LinterState (State [Text]) ())
-> StateT LinterState (State [Text]) ()
-> StateT LinterState (State [Text]) ()
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> Type -> StateT LinterState (State [Text]) ()
checkStmt Node (Lexeme Text)
body Type
expectedRetType
typeCheckFunc Node (Lexeme Text)
_ Node (Lexeme Text)
_ = () -> StateT LinterState (State [Text]) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Linter Entry

-- | The main analysis function.
analyse :: [TranslationUnit] -> [Text]
analyse :: [TranslationUnit] -> [Text]
analyse [TranslationUnit]
tus =
    let
        initialState :: LinterState
initialState = TypeEnv
-> StructEnv
-> StructEnv
-> Map Text Type
-> Subst
-> Int
-> String
-> LinterState
LinterState TypeEnv
forall k a. Map k a
Map.empty StructEnv
forall k a. Map k a
Map.empty StructEnv
forall k a. Map k a
Map.empty Map Text Type
forall k a. Map k a
Map.empty Subst
forall k a. Map k a
Map.empty Int
0 String
""
        linterM :: StateT LinterState (State [Text]) ()
linterM = do
            (TranslationUnit -> StateT LinterState (State [Text]) ())
-> [TranslationUnit] -> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TranslationUnit -> StateT LinterState (State [Text]) ()
collectGlobals [TranslationUnit]
tus
            (TranslationUnit -> StateT LinterState (State [Text]) ())
-> [TranslationUnit] -> StateT LinterState (State [Text]) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TranslationUnit -> StateT LinterState (State [Text]) ()
typeCheckFile [TranslationUnit]
tus
    in
        [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ ((), [Text]) -> [Text]
forall a b. (a, b) -> b
snd (((), [Text]) -> [Text]) -> ((), [Text]) -> [Text]
forall a b. (a -> b) -> a -> b
$ StateT [Text] Identity () -> [Text] -> ((), [Text])
forall s a. State s a -> s -> (a, s)
runState (StateT LinterState (State [Text]) ()
-> LinterState -> StateT [Text] Identity ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT LinterState (State [Text]) ()
linterM LinterState
initialState) []

descr :: ([TranslationUnit] -> [Text], (Text, Text))
descr :: ([TranslationUnit] -> [Text], (Text, Text))
descr = ([TranslationUnit] -> [Text]
analyse, (Text
"type-check", [Text] -> Text
Text.unlines
    [ Text
"A Hindley-Milner based type checker for Cimple."
    , Text
"It checks for type consistency in expressions, assignments, and function calls."
    ]))