{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE Strict         #-}
module Tokstyle.C.Env
    ( DiagnosticLevel(..)
    , DiagnosticSpan(..)
    , CPosition(..)
    , LinterError
    , Env(..)
    , defaultEnv
    , bracketUserState
    , getCtx
    , pushCtx
    , popCtx
    , getRetTy
    , setRetTy
    , unsetRetTy
    , recordLinterError
    , recordRichError
    , safePosFile
    , posAndLen
    ) where

import           Data.Map.Strict               (Map)
import qualified Data.Map.Strict               as Map
import           Data.Text                     (Text)
import           Language.C.Analysis.SemRep    (GlobalDecls, IdentDecl, Type)
import           Language.C.Analysis.TravMonad (Trav, getUserState,
                                                modifyUserState)
import           Language.C.Data.Ident         (Ident, SUERef)
import           Language.C.Data.Node          (NodeInfo (..), nodeInfo)
import           Language.C.Data.Position      as C
import           Language.Cimple.Diagnostics   (Diagnostic (..),
                                                DiagnosticLevel (..),
                                                DiagnosticSpan (..),
                                                IsPosition (..))
import           Prettyprinter                 (Doc)

import           Prettyprinter.Render.Terminal (AnsiStyle)
import           Tokstyle.C.Analysis.Interval  (Program, emptyProgram)
import           Tokstyle.C.Analysis.Program   (Analysed)
import           Tokstyle.C.TravUtils          (getJust)

newtype CPosition = CPosition { CPosition -> Position
unCPosition :: Position }
    deriving (Int -> CPosition -> ShowS
[CPosition] -> ShowS
CPosition -> String
(Int -> CPosition -> ShowS)
-> (CPosition -> String)
-> ([CPosition] -> ShowS)
-> Show CPosition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CPosition -> ShowS
showsPrec :: Int -> CPosition -> ShowS
$cshow :: CPosition -> String
show :: CPosition -> String
$cshowList :: [CPosition] -> ShowS
showList :: [CPosition] -> ShowS
Show, CPosition -> CPosition -> Bool
(CPosition -> CPosition -> Bool)
-> (CPosition -> CPosition -> Bool) -> Eq CPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CPosition -> CPosition -> Bool
== :: CPosition -> CPosition -> Bool
$c/= :: CPosition -> CPosition -> Bool
/= :: CPosition -> CPosition -> Bool
Eq)

instance IsPosition CPosition where
    posFile :: CPosition -> String
posFile = Position -> String
C.posFile (Position -> String)
-> (CPosition -> Position) -> CPosition -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPosition -> Position
unCPosition
    posLine :: CPosition -> Int
posLine = Position -> Int
C.posRow (Position -> Int) -> (CPosition -> Position) -> CPosition -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPosition -> Position
unCPosition
    posColumn :: CPosition -> Int
posColumn = Position -> Int
C.posColumn (Position -> Int) -> (CPosition -> Position) -> CPosition -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPosition -> Position
unCPosition
    isRealPos :: CPosition -> Bool
isRealPos = Position -> Bool
C.isSourcePos (Position -> Bool) -> (CPosition -> Position) -> CPosition -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CPosition -> Position
unCPosition

type LinterError = Diagnostic CPosition

data Env = Env
    { Env -> [String]
ctx           :: [String]
    , Env -> Maybe Type
retTy         :: Maybe Type
    , Env -> [Ident]
params        :: [Ident]
    , Env -> Map Ident Type
inferredTypes :: Map Ident Type
    , Env -> Map SUERef Ident
mainTypedefs  :: Map SUERef Ident
    , Env -> Maybe GlobalDecls
globalDecls   :: Maybe GlobalDecls
    , Env -> [LinterError]
linterErrors  :: [LinterError]
    , Env -> Maybe Text
currentFlag   :: Maybe Text
    , Env -> Program
program       :: Program
    -- ^ What is known about the program the translation unit is part of.
    , Env -> Map String [IdentDecl]
localsOf      :: Map String [IdentDecl]
    -- ^ The locals each function declares.
    , Env -> [IdentDecl]
pendingLocals :: [IdentDecl]
    -- ^ The locals of the function being analysed, in reverse.
    , Env -> [Analysed]
analysed      :: [Analysed]
    -- ^ The functions of the translation unit the interval linters look at,
    -- analysed knowing nothing about the rest of the program.
    }

defaultEnv :: Env
defaultEnv :: Env
defaultEnv = [String]
-> Maybe Type
-> [Ident]
-> Map Ident Type
-> Map SUERef Ident
-> Maybe GlobalDecls
-> [LinterError]
-> Maybe Text
-> Program
-> Map String [IdentDecl]
-> [IdentDecl]
-> [Analysed]
-> Env
Env [String
"file"] Maybe Type
forall a. Maybe a
Nothing [] Map Ident Type
forall k a. Map k a
Map.empty Map SUERef Ident
forall k a. Map k a
Map.empty Maybe GlobalDecls
forall a. Maybe a
Nothing [] Maybe Text
forall a. Maybe a
Nothing Program
emptyProgram Map String [IdentDecl]
forall k a. Map k a
Map.empty [] []


bracketUserState :: (Env -> Env) -> Trav Env a -> Trav Env a
bracketUserState :: forall a. (Env -> Env) -> Trav Env a -> Trav Env a
bracketUserState Env -> Env
f Trav Env a
act = do
    Env
s <- Trav Env Env
forall s. Trav s s
getUserState
    (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState Env -> Env
f
    a
r <- Trav Env a
act
    (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
s' -> Env
s{linterErrors = linterErrors s'}
    a -> Trav Env a
forall a. a -> TravT Env Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r


getCtx :: Trav Env [String]
getCtx :: Trav Env [String]
getCtx = Env -> [String]
ctx (Env -> [String]) -> Trav Env Env -> Trav Env [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Trav Env Env
forall s. Trav s s
getUserState

pushCtx :: String -> Trav Env ()
pushCtx :: String -> Trav Env ()
pushCtx String
s = (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \env :: Env
env@Env{[String]
ctx :: Env -> [String]
ctx :: [String]
ctx} -> Env
env{ctx = s:ctx}

popCtx :: Trav Env ()
popCtx :: Trav Env ()
popCtx = (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \env :: Env
env@Env{[String]
ctx :: Env -> [String]
ctx :: [String]
ctx} -> Env
env{ctx = drop 1 ctx}


getRetTy :: Trav Env Type
getRetTy :: Trav Env Type
getRetTy = Trav Env Env
forall s. Trav s s
getUserState Trav Env Env -> (Env -> Trav Env Type) -> Trav Env Type
forall a b.
TravT Env Identity a
-> (a -> TravT Env Identity b) -> TravT Env Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Type -> Trav Env Type
forall (m :: * -> *) a. MonadTrav m => String -> Maybe a -> m a
getJust String
"not in function context" (Maybe Type -> Trav Env Type)
-> (Env -> Maybe Type) -> Env -> Trav Env Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> Maybe Type
retTy

setRetTy :: Type -> Trav Env ()
setRetTy :: Type -> Trav Env ()
setRetTy Type
t = (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{retTy = Just t}

unsetRetTy :: Trav Env ()
unsetRetTy :: Trav Env ()
unsetRetTy = (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env -> Env
env{retTy = Nothing}

recordLinterError :: NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError :: NodeInfo -> Doc AnsiStyle -> Trav Env ()
recordLinterError NodeInfo
info Doc AnsiStyle
doc = (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    let (Position
pos, Int
len) = NodeInfo -> (Position, Int)
posAndLen NodeInfo
info
    in Env
env{linterErrors = Diagnostic (CPosition pos) len ErrorLevel doc (currentFlag env) [] [] : linterErrors env}

recordRichError :: NodeInfo -> DiagnosticLevel -> Doc AnsiStyle -> [DiagnosticSpan Position] -> [(DiagnosticLevel, Doc AnsiStyle)] -> Trav Env ()
recordRichError :: NodeInfo
-> DiagnosticLevel
-> Doc AnsiStyle
-> [DiagnosticSpan Position]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Trav Env ()
recordRichError NodeInfo
info DiagnosticLevel
level Doc AnsiStyle
msg [DiagnosticSpan Position]
spans [(DiagnosticLevel, Doc AnsiStyle)]
footer = (Env -> Env) -> Trav Env ()
forall s. (s -> s) -> Trav s ()
modifyUserState ((Env -> Env) -> Trav Env ()) -> (Env -> Env) -> Trav Env ()
forall a b. (a -> b) -> a -> b
$ \Env
env ->
    let (Position
pos, Int
len) = NodeInfo -> (Position, Int)
posAndLen NodeInfo
info
        wrapSpan :: DiagnosticSpan Position -> DiagnosticSpan CPosition
wrapSpan DiagnosticSpan Position
s = DiagnosticSpan Position
s { spanPos = CPosition (spanPos s) }
    in Env
env{linterErrors = Diagnostic (CPosition pos) len level msg (currentFlag env) (map wrapSpan spans) footer : linterErrors env}

safePosFile :: Position -> String
safePosFile :: Position -> String
safePosFile Position
p | Position -> Bool
C.isSourcePos Position
p = Position -> String
C.posFile Position
p
              | Position -> Bool
isNoPos Position
p = String
"<no file>"
              | Position -> Bool
isBuiltinPos Position
p = String
"<builtin>"
              | Position -> Bool
isInternalPos Position
p = String
"<internal>"
              | Bool
otherwise = String
"<unknown>"

posAndLen :: NodeInfo -> (Position, Int)
posAndLen :: NodeInfo -> (Position, Int)
posAndLen NodeInfo
info = case NodeInfo -> NodeInfo
forall a. CNode a => a -> NodeInfo
nodeInfo NodeInfo
info of
    NodeInfo Position
pos (Position
lastPos, Int
lastLen) Name
_ -> (Position
pos, Position -> Position -> Int -> Int
calcLen Position
pos Position
lastPos Int
lastLen)
    OnlyPos Position
pos (Position
lastPos, Int
lastLen)    -> (Position
pos, Position -> Position -> Int -> Int
calcLen Position
pos Position
lastPos Int
lastLen)
  where
    calcLen :: Position -> Position -> Int -> Int
calcLen Position
pos Position
lastPos Int
lastLen =
        if Position -> Bool
C.isSourcePos Position
pos Bool -> Bool -> Bool
&& Position -> Bool
C.isSourcePos Position
lastPos Bool -> Bool -> Bool
&& Position -> String
safePosFile Position
pos String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Position -> String
safePosFile Position
lastPos Bool -> Bool -> Bool
&& Position -> Int
C.posRow Position
pos Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Position -> Int
C.posRow Position
lastPos
        then (Position -> Int
C.posColumn Position
lastPos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lastLen) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Position -> Int
C.posColumn Position
pos
        else Int
lastLen