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

import           Data.Fix                   (Fix (..))
import           Data.Maybe                 (mapMaybe)
import           Data.Text                  (Text)
import qualified Data.Text                  as Text
import           Language.Cimple            (Lexeme (..), LexemeClass (..),
                                             LiteralType (..), Node, NodeF (..),
                                             lexemeText)
import           Tokstyle.Common.EnumLinter (EnumInfo (EnumInfo), MkFunBody,
                                             analyseEnums, mkLAt)


funSuffix :: Text
funSuffix :: Text
funSuffix = Text
"_to_string"

mkReturnString :: Lexeme Text -> Text -> Node (Lexeme Text)
mkReturnString :: Lexeme Text -> Text -> Node (Lexeme Text)
mkReturnString Lexeme Text
at Text
str = 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
String (Lexeme Text -> LexemeClass -> Text -> Lexeme Text
forall a. Lexeme a -> LexemeClass -> a -> Lexeme a
mkLAt Lexeme Text
at LexemeClass
LitString Text
str)))))

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)) (Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text)))
-> Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall a b. (a -> b) -> a -> b
$
         Lexeme Text -> Text -> Node (Lexeme Text)
mkReturnString Lexeme Text
name (Text -> Node (Lexeme Text)) -> Text -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Lexeme Text -> Text
forall text. Lexeme text -> text
lexemeText Lexeme Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
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

mkFunBody :: MkFunBody
mkFunBody :: MkFunBody
mkFunBody SymbolTable
_ Lexeme Text
varName (EnumInfo Text
ename [Node (Lexeme Text)]
enumrs) = do
    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))
        , Lexeme Text -> Text -> Node (Lexeme Text)
mkReturnString Lexeme Text
varName (Text -> Node (Lexeme Text)) -> Text -> Node (Lexeme Text)
forall a b. (a -> b) -> a -> b
$ Text
"\"<invalid " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ename Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">\""
        ])


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-to-string", [Text] -> Text
Text.unlines
    [ Text
"Checks that `_to_string` functions for `enum`s are complete."
    , Text
""
    , Text
"**Reason:** we provide `to_string` functions for `enum` but don't want to"
    , Text
"manually maintain them. This linter checks that the function is exactly what"
    , Text
"we want it to be, and the error message will say what the function should look"
    , Text
"like."
    ]))