{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
module Tokstyle.SemFmt.EnumFromInt (descr) where

import           Control.Applicative        ((<|>))
import           Data.Fix                   (Fix (..))
import           Data.List.Extra            (firstJust)
import           Data.Maybe                 (mapMaybe)
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import           Language.Cimple            (AssignOp (..), Lexeme (..),
                                             LexemeClass (..), LiteralType (..),
                                             Node, NodeF (..), UnaryOp (..))
import           Tokstyle.Common.EnumLinter (EnumInfo (..), MkFunBody,
                                             analyseEnums, mkLAt)


funSuffix :: Text
funSuffix :: Text
funSuffix = Text
"_from_int"

mkCase :: Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
mkCase :: Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
mkCase (Fix Comment{}) = Maybe (Node (Lexeme Text))
forall a. Maybe a
Nothing
mkCase (Fix (Commented Node (Lexeme Text)
_ Node (Lexeme Text)
e)) = Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
mkCase Node (Lexeme Text)
e
mkCase (Fix (Enumerator Lexeme Text
name Maybe (Node (Lexeme Text))
_)) = Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just (Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$
    -- case $name: return $name;
    NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> a -> NodeF lexeme a
Case (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (LiteralType
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. LiteralType -> lexeme -> NodeF lexeme a
LiteralExpr LiteralType
ConstId Lexeme Text
name))
         (Lexeme Text -> (LexemeClass, Text) -> Node (Lexeme Text)
mkAssignOut Lexeme Text
name (LexemeClass
LitTrue, Text
"true")))
mkCase Node (Lexeme Text)
node = [Char] -> Maybe (Node (Lexeme Text))
forall a. HasCallStack => [Char] -> a
error ([Char] -> Maybe (Node (Lexeme Text)))
-> [Char] -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> [Char]
forall a. Show a => a -> [Char]
show Node (Lexeme Text)
node

mkAssignOut :: Lexeme Text -> (LexemeClass, Text) -> Node (Lexeme Text)
mkAssignOut :: Lexeme Text -> (LexemeClass, Text) -> Node (Lexeme Text)
mkAssignOut Lexeme Text
name (LexemeClass
retCls, Text
retStr) =
    let outDeref :: Node (Lexeme Text)
outDeref = NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (UnaryOp
-> Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. UnaryOp -> a -> NodeF lexeme a
UnaryExpr UnaryOp
UopDeref (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
name LexemeClass
IdVar Text
"out_enum")))) in
    NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ [Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. [a] -> NodeF lexeme a
CompoundStmt
        [ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> NodeF lexeme a
ExprStmt (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> AssignOp
-> Node (Lexeme Text)
-> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> AssignOp -> a -> NodeF lexeme a
AssignExpr Node (Lexeme Text)
outDeref AssignOp
AopEq (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (LiteralType
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. LiteralType -> lexeme -> NodeF lexeme a
LiteralExpr LiteralType
ConstId Lexeme Text
name)))))
        , NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Maybe (Node (Lexeme Text))
-> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. Maybe a -> NodeF lexeme a
Return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a. a -> Maybe a
Just (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (LiteralType
-> Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. LiteralType -> lexeme -> NodeF lexeme a
LiteralExpr LiteralType
Bool (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
name LexemeClass
retCls Text
retStr)))))
        ]

mkFunBody :: MkFunBody
mkFunBody :: MkFunBody
mkFunBody SymbolTable
_ Lexeme Text
varName (EnumInfo Text
_ [Node (Lexeme Text)]
enumrs) = do
    Lexeme Text
dn <- Maybe (Lexeme Text)
defaultName
    let defaultCase :: Node (Lexeme Text)
defaultCase = NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> NodeF lexeme a
Default (Lexeme Text -> (LexemeClass, Text) -> Node (Lexeme Text)
mkAssignOut Lexeme Text
dn (LexemeClass
LitFalse, Text
"false")))
    Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$ NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ([Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. [a] -> NodeF lexeme a
CompoundStmt
        [NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Node (Lexeme Text)
-> [Node (Lexeme Text)] -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. a -> [a] -> NodeF lexeme a
SwitchStmt (NodeF (Lexeme Text) (Node (Lexeme Text)) -> Node (Lexeme Text)
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Lexeme Text -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall lexeme a. lexeme -> NodeF lexeme a
VarExpr Lexeme Text
varName)) ((Node (Lexeme Text) -> Maybe (Node (Lexeme Text)))
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Node (Lexeme Text) -> Maybe (Node (Lexeme Text))
mkCase [Node (Lexeme Text)]
enumrs [Node (Lexeme Text)]
-> [Node (Lexeme Text)] -> [Node (Lexeme Text)]
forall a. [a] -> [a] -> [a]
++ [Node (Lexeme Text)
defaultCase]))])
  where
    defaultName :: Maybe (Lexeme Text)
defaultName =
        (Node (Lexeme Text) -> Maybe (Lexeme Text))
-> [Node (Lexeme Text)] -> Maybe (Lexeme Text)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust Node (Lexeme Text) -> Maybe (Lexeme Text)
isDefault [Node (Lexeme Text)]
enumrs Maybe (Lexeme Text) -> Maybe (Lexeme Text) -> Maybe (Lexeme Text)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Node (Lexeme Text) -> Maybe (Lexeme Text))
-> [Node (Lexeme Text)] -> Maybe (Lexeme Text)
forall a b. (a -> Maybe b) -> [a] -> Maybe b
firstJust Node (Lexeme Text) -> Maybe (Lexeme Text)
forall a. Fix (NodeF a) -> Maybe a
isEnumr [Node (Lexeme Text)]
enumrs
    isDefault :: Node (Lexeme Text) -> Maybe (Lexeme Text)
isDefault (Fix (Commented Node (Lexeme Text)
_ Node (Lexeme Text)
e)) = Node (Lexeme Text) -> Maybe (Lexeme Text)
isDefault Node (Lexeme Text)
e
    isDefault (Fix (Enumerator l :: Lexeme Text
l@(L AlexPosn
_ LexemeClass
_ Text
name) Maybe (Node (Lexeme Text))
_))
        | Text
"_INVALID" Text -> Text -> Bool
`Text.isSuffixOf` Text
name = Lexeme Text -> Maybe (Lexeme Text)
forall a. a -> Maybe a
Just Lexeme Text
l
    isDefault Node (Lexeme Text)
_ = Maybe (Lexeme Text)
forall a. Maybe a
Nothing
    isEnumr :: Fix (NodeF a) -> Maybe a
isEnumr (Fix (Commented Fix (NodeF a)
_ Fix (NodeF a)
e))  = Fix (NodeF a) -> Maybe a
isEnumr Fix (NodeF a)
e
    isEnumr (Fix (Enumerator a
l Maybe (Fix (NodeF a))
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
l
    isEnumr Fix (NodeF a)
_                      = Maybe a
forall a. Maybe a
Nothing


analyse :: [(FilePath, [Node (Lexeme Text)])] -> [Text]
analyse :: [([Char], [Node (Lexeme Text)])] -> [Text]
analyse = Text -> MkFunBody -> [([Char], [Node (Lexeme Text)])] -> [Text]
analyseEnums Text
funSuffix MkFunBody
mkFunBody

descr :: ([(FilePath, [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr :: ([([Char], [Node (Lexeme Text)])] -> [Text], (Text, Text))
descr = ([([Char], [Node (Lexeme Text)])] -> [Text]
analyse, (Text
"enum-from-int", [Text] -> Text
Text.unlines
    [ Text
"Checks that `_from_int` functions for `enum`s are complete."
    , Text
""
    , Text
"**Reason:** ensures that no enumerators are missed in conversion functions that"
    , Text
"turn `int`s into `enum`s. Type-cast is not permitted, because some values of"
    , Text
"type `int` are not in the enumeration."
    ]))