{-|
Module      : Htcc.Parser.ConstructionData.Scope.Tag
Description : The Data type of struct and its utilities used in parsing
Copyright   : (c) roki, 2019
License     : MIT
Maintainer  : falgon53@yahoo.co.jp
Stability   : experimental
Portability : POSIX

The Data type of variables and its utilities used in parsing
-}
{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
module Htcc.Parser.ConstructionData.Scope.Tag (
    Tag (..),
    Tags,
    add
) where

import           Control.DeepSeq                                 (NFData (..))
import qualified Data.Map                                        as M
import qualified Data.Text                                       as T
import           GHC.Generics                                    (Generic (..))
import           Numeric.Natural

import qualified Htcc.CRules.Types                               as CT
import           Htcc.Parser.ConstructionData.Scope.ManagedScope
import           Htcc.Parser.ConstructionData.Scope.Utils        (internalCE)
import qualified Htcc.Tokenizer.Token                            as HT

-- | The data type of a tag
data Tag i = Tag -- ^ The constructor of a tag
    {
        Tag i -> StorageClass i
sttype      :: CT.StorageClass i, -- ^ The type of this tag
        Tag i -> Natural
stNestDepth :: !Natural -- ^ The nest depth of this tag
    } deriving (Tag i -> Tag i -> Bool
(Tag i -> Tag i -> Bool) -> (Tag i -> Tag i -> Bool) -> Eq (Tag i)
forall i. Eq i => Tag i -> Tag i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag i -> Tag i -> Bool
$c/= :: forall i. Eq i => Tag i -> Tag i -> Bool
== :: Tag i -> Tag i -> Bool
$c== :: forall i. Eq i => Tag i -> Tag i -> Bool
Eq, Eq (Tag i)
Eq (Tag i) =>
(Tag i -> Tag i -> Ordering)
-> (Tag i -> Tag i -> Bool)
-> (Tag i -> Tag i -> Bool)
-> (Tag i -> Tag i -> Bool)
-> (Tag i -> Tag i -> Bool)
-> (Tag i -> Tag i -> Tag i)
-> (Tag i -> Tag i -> Tag i)
-> Ord (Tag i)
Tag i -> Tag i -> Bool
Tag i -> Tag i -> Ordering
Tag i -> Tag i -> Tag i
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
forall i. Ord i => Eq (Tag i)
forall i. Ord i => Tag i -> Tag i -> Bool
forall i. Ord i => Tag i -> Tag i -> Ordering
forall i. Ord i => Tag i -> Tag i -> Tag i
min :: Tag i -> Tag i -> Tag i
$cmin :: forall i. Ord i => Tag i -> Tag i -> Tag i
max :: Tag i -> Tag i -> Tag i
$cmax :: forall i. Ord i => Tag i -> Tag i -> Tag i
>= :: Tag i -> Tag i -> Bool
$c>= :: forall i. Ord i => Tag i -> Tag i -> Bool
> :: Tag i -> Tag i -> Bool
$c> :: forall i. Ord i => Tag i -> Tag i -> Bool
<= :: Tag i -> Tag i -> Bool
$c<= :: forall i. Ord i => Tag i -> Tag i -> Bool
< :: Tag i -> Tag i -> Bool
$c< :: forall i. Ord i => Tag i -> Tag i -> Bool
compare :: Tag i -> Tag i -> Ordering
$ccompare :: forall i. Ord i => Tag i -> Tag i -> Ordering
$cp1Ord :: forall i. Ord i => Eq (Tag i)
Ord, Int -> Tag i -> ShowS
[Tag i] -> ShowS
Tag i -> String
(Int -> Tag i -> ShowS)
-> (Tag i -> String) -> ([Tag i] -> ShowS) -> Show (Tag i)
forall i. Show i => Int -> Tag i -> ShowS
forall i. Show i => [Tag i] -> ShowS
forall i. Show i => Tag i -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag i] -> ShowS
$cshowList :: forall i. Show i => [Tag i] -> ShowS
show :: Tag i -> String
$cshow :: forall i. Show i => Tag i -> String
showsPrec :: Int -> Tag i -> ShowS
$cshowsPrec :: forall i. Show i => Int -> Tag i -> ShowS
Show, (forall x. Tag i -> Rep (Tag i) x)
-> (forall x. Rep (Tag i) x -> Tag i) -> Generic (Tag i)
forall x. Rep (Tag i) x -> Tag i
forall x. Tag i -> Rep (Tag i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall i x. Rep (Tag i) x -> Tag i
forall i x. Tag i -> Rep (Tag i) x
$cto :: forall i x. Rep (Tag i) x -> Tag i
$cfrom :: forall i x. Tag i -> Rep (Tag i) x
Generic)

instance NFData i => NFData (Tag i)

instance ManagedScope (Tag i) where
    lookup :: Text -> Map Text (Tag i) -> Maybe (Tag i)
lookup = Text -> Map Text (Tag i) -> Maybe (Tag i)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup
    fallBack :: Map Text (Tag i) -> Map Text (Tag i) -> Map Text (Tag i)
fallBack = Map Text (Tag i) -> Map Text (Tag i) -> Map Text (Tag i)
forall a b. a -> b -> a
const
    initial :: Map Text (Tag i)
initial = Map Text (Tag i)
forall k a. Map k a
M.empty

-- | The `Tags` data type
type Tags i = M.Map T.Text (Tag i)

-- | Given the current nesting number, type, identifier token, and `Tags`, if the specified identifier already exists in the same scope,
-- return an error message and its location as a pair.
-- Otherwise, add a new tag to `Tags` and return it.
-- If the token does not indicate an identifier, an error indicating internal compiler error is returned.
add :: Num i => Natural -> CT.StorageClass i -> HT.TokenLC i -> Tags i -> Either (ASTError i) (Tags i)
add :: Natural
-> StorageClass i
-> TokenLC i
-> Tags i
-> Either (ASTError i) (Tags i)
add cnd :: Natural
cnd t :: StorageClass i
t cur :: TokenLC i
cur@(_, HT.TKIdent ident :: Text
ident) sts :: Tags i
sts = case Text -> Tags i -> Maybe (Tag i)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
ident Tags i
sts of
    Just foundedTag :: Tag i
foundedTag
        | Tag i -> Natural
forall i. Tag i -> Natural
stNestDepth Tag i
foundedTag Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
/= Natural
cnd -> Either (ASTError i) (Tags i)
forall a. Either a (Tags i)
stnat
        | StorageClass i -> Bool
forall (a :: * -> *) i. TypeKindBase a => a i -> Bool
CT.isCTIncomplete (Tag i -> StorageClass i
forall i. Tag i -> StorageClass i
sttype Tag i
foundedTag) -> Either (ASTError i) (Tags i)
forall a. Either a (Tags i)
stnat
        | Bool
otherwise -> ASTError i -> Either (ASTError i) (Tags i)
forall a b. a -> Either a b
Left ("redefinition of 'struct " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "'", TokenLC i
cur) -- ODR
    Nothing -> Either (ASTError i) (Tags i)
forall a. Either a (Tags i)
stnat
    where
        stnat :: Either a (Tags i)
stnat = Tags i -> Either a (Tags i)
forall a b. b -> Either a b
Right (Tags i -> Either a (Tags i)) -> Tags i -> Either a (Tags i)
forall a b. (a -> b) -> a -> b
$ Text -> Tag i -> Tags i -> Tags i
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
ident (StorageClass i -> Natural -> Tag i
forall i. StorageClass i -> Natural -> Tag i
Tag StorageClass i
t Natural
cnd) Tags i
sts
add _ _ _ _ = ASTError i -> Either (ASTError i) (Tags i)
forall a b. a -> Either a b
Left (Text
internalCE, (i -> i -> TokenLCNums i
forall i. i -> i -> TokenLCNums i
HT.TokenLCNums 0 0, Token i
forall i. Token i
HT.TKEmpty))