{-# 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, 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.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
showList :: [CPosition] -> ShowS
$cshowList :: [CPosition] -> ShowS
show :: CPosition -> String
$cshow :: CPosition -> String
showsPrec :: Int -> CPosition -> ShowS
$cshowsPrec :: Int -> CPosition -> ShowS
Show, CPosition -> CPosition -> Bool
(CPosition -> CPosition -> Bool)
-> (CPosition -> CPosition -> Bool) -> Eq CPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CPosition -> CPosition -> Bool
$c/= :: CPosition -> CPosition -> Bool
== :: CPosition -> CPosition -> Bool
$c== :: 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
    }

defaultEnv :: Env
defaultEnv :: Env
defaultEnv = [String]
-> Maybe Type
-> [Ident]
-> Map Ident Type
-> Map SUERef Ident
-> Maybe GlobalDecls
-> [LinterError]
-> Maybe Text
-> 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

bracketUserState :: (Env -> Env) -> Trav Env a -> Trav Env a
bracketUserState :: (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 :: [LinterError]
linterErrors = Env -> [LinterError]
linterErrors Env
s'}
    a -> Trav Env 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 :: [String]
ctx :: Env -> [String]
ctx} -> Env
env{ctx :: [String]
ctx = String
sString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
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 :: [String]
ctx :: Env -> [String]
ctx} -> Env
env{ctx :: [String]
ctx = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
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 (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 :: Maybe Type
retTy = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
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 :: Maybe Type
retTy = Maybe Type
forall a. Maybe a
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 :: [LinterError]
linterErrors = CPosition
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan CPosition]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> LinterError
forall pos.
pos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan pos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic pos
Diagnostic (Position -> CPosition
CPosition Position
pos) Int
len DiagnosticLevel
ErrorLevel Doc AnsiStyle
doc (Env -> Maybe Text
currentFlag Env
env) [] [] LinterError -> [LinterError] -> [LinterError]
forall a. a -> [a] -> [a]
: Env -> [LinterError]
linterErrors Env
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 = Position -> CPosition
CPosition (DiagnosticSpan Position -> Position
forall pos. DiagnosticSpan pos -> pos
spanPos DiagnosticSpan Position
s) }
    in Env
env{linterErrors :: [LinterError]
linterErrors = CPosition
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan CPosition]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> LinterError
forall pos.
pos
-> Int
-> DiagnosticLevel
-> Doc AnsiStyle
-> Maybe Text
-> [DiagnosticSpan pos]
-> [(DiagnosticLevel, Doc AnsiStyle)]
-> Diagnostic pos
Diagnostic (Position -> CPosition
CPosition Position
pos) Int
len DiagnosticLevel
level Doc AnsiStyle
msg (Env -> Maybe Text
currentFlag Env
env) ((DiagnosticSpan Position -> DiagnosticSpan CPosition)
-> [DiagnosticSpan Position] -> [DiagnosticSpan CPosition]
forall a b. (a -> b) -> [a] -> [b]
map DiagnosticSpan Position -> DiagnosticSpan CPosition
wrapSpan [DiagnosticSpan Position]
spans) [(DiagnosticLevel, Doc AnsiStyle)]
footer LinterError -> [LinterError] -> [LinterError]
forall a. a -> [a] -> [a]
: Env -> [LinterError]
linterErrors Env
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