{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TupleSections     #-}
module Apigen.Language.Haskell where

import           Control.Monad.State.Strict  (State)
import qualified Control.Monad.State.Strict  as State
import           Data.Fix                    (Fix (..))
import           Data.Maybe                  (catMaybes)
import           Data.Text                   (Text)
import qualified Data.Text                   as Text
import           Language.Cimple             (Lexeme (..), LexemeClass (..),
                                              Node, NodeF (..))
import           Language.Cimple.TraverseAst (AstActions, astActions, doNode,
                                              traverseAst)
import qualified Text.Casing                 as Casing


joinLines :: [Text] -> Text
joinLines :: [Text] -> Text
joinLines = Text -> [Text] -> Text
Text.intercalate Text
"\n"


idToHaskell :: Text -> Text
idToHaskell :: Text -> Text
idToHaskell =
    String -> Text
Text.pack
    (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
Casing.toPascal
    (Identifier String -> String)
-> (Text -> Identifier String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Identifier String
forall a. [a] -> Identifier a
Casing.Identifier
    ([String] -> Identifier String)
-> (Text -> [String]) -> Text -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
dropNamespace
    ([String] -> [String]) -> (Text -> [String]) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> [String]
forall a. Identifier a -> [a]
Casing.unIdentifier
    (Identifier String -> [String])
-> (Text -> Identifier String) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
Casing.fromSnake
    (String -> Identifier String)
-> (Text -> String) -> Text -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
  where
    -- Drop the first component of the name, but only if there are at least
    -- 2 components.
    dropNamespace :: [a] -> [a]
dropNamespace (a
_:name :: [a]
name@(a
_:[a]
_)) = [a]
name
    dropNamespace [a]
name           = [a]
name


maybeParen :: Text -> Text
maybeParen :: Text -> Text
maybeParen Text
name
    | Char
' ' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> String
Text.unpack Text
name = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    | Bool
otherwise                   = Text
name


isErrorEnum :: Text -> Bool
isErrorEnum :: Text -> Bool
isErrorEnum Text
tyName =
    case Identifier String -> [String]
forall a. Identifier a -> [a]
Casing.unIdentifier (Identifier String -> [String])
-> (Text -> Identifier String) -> Text -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
Casing.fromSnake (String -> Identifier String)
-> (Text -> String) -> Text -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> [String]) -> Text -> [String]
forall a b. (a -> b) -> a -> b
$ Text
tyName of
        (String
_:String
"Err":[String]
_) -> Bool
True
        [String]
_           -> Bool
False


genStdType :: Text -> Text
genStdType :: Text -> Text
genStdType Text
"uint16_t" = Text
"Word16"
genStdType Text
"uint32_t" = Text
"Word32"
genStdType Text
"uint64_t" = Text
"Word64"
genStdType Text
"size_t"   = Text
"CSize"
genStdType Text
"bool"     = Text
"Bool"
genStdType Text
tyName     = String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. Show a => a -> String
show Text
tyName


genType :: Node (Lexeme Text) -> Text
genType :: Node (Lexeme Text) -> Text
genType                               (Fix (TyUserDefined (L AlexPosn
_ LexemeClass
IdSueType Text
tyName))) =
    Text
"CEnum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
idToHaskell Text
tyName
genType (Fix (TyPointer               (Fix (TyUserDefined (L AlexPosn
_ LexemeClass
IdSueType Text
tyName)))  ))
    | Text -> Bool
isErrorEnum Text
tyName = Text
"CErr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
idToHaskell Text
tyName
    | Bool
otherwise = Text -> Text
idToHaskell Text
tyName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Ptr"

genType (Fix (TyPointer (Fix (TyConst (Fix (TyUserDefined (L AlexPosn
_ LexemeClass
IdSueType Text
tyName))))))) =
    Text -> Text
idToHaskell Text
tyName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Ptr"
genType (Fix (TyPointer (Fix (TyConst (Fix (TyStruct (L AlexPosn
_ LexemeClass
IdSueType Text
tyName))))))) =
    Text -> Text
idToHaskell Text
tyName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Ptr"
genType (Fix (TyPointer               (Fix (TyStruct (L AlexPosn
_ LexemeClass
IdSueType Text
tyName)))  )) =
    Text -> Text
idToHaskell Text
tyName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Ptr"

genType (Fix (TyPointer               (Fix (TyStd (L AlexPosn
_ LexemeClass
IdStdType Text
"uint8_t")))  )) =
    Text
"CString"
genType (Fix (TyPointer (Fix (TyConst (Fix (TyStd (L AlexPosn
_ LexemeClass
IdStdType Text
"uint8_t"))))))) =
    Text
"CString"
genType (Fix (TyPointer (Fix (TyConst (Fix (TyStd (L AlexPosn
_ LexemeClass
IdStdType Text
"char"))))))) =
    Text
"CString"

genType (Fix (TyPointer (Fix (TyStd (L AlexPosn
_ LexemeClass
KwVoid Text
_))))) =
    Text
"Ptr ()"
genType (Fix (TyPointer (Fix (TyFunc (L AlexPosn
_ LexemeClass
IdFuncType Text
tyName))))) =
    Text
"FunPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
idToHaskell Text
tyName
genType                 (Fix (TyStd (L AlexPosn
_ LexemeClass
IdStdType Text
tyName))) =
    Text -> Text
genStdType Text
tyName
genType (Fix (TyPointer (Fix (TyStd (L AlexPosn
_ LexemeClass
IdStdType Text
tyName))))) =
    Text
"Ptr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
genStdType Text
tyName
genType (Fix (TyStd (L AlexPosn
_ LexemeClass
KwVoid Text
_))) =
    Text
"()"
genType Node (Lexeme Text)
ty = String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> String
forall a. Show a => a -> String
show Node (Lexeme Text)
ty


genArg :: Node (Lexeme Text) -> Text
genArg :: Node (Lexeme Text) -> Text
genArg (Fix (VarDecl Node (Lexeme Text)
ty Lexeme Text
_ [Node (Lexeme Text)]
_)) = Node (Lexeme Text) -> Text
genType Node (Lexeme Text)
ty
genArg Node (Lexeme Text)
arg                    = String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> String
forall a. Show a => a -> String
show Node (Lexeme Text)
arg


genArgs :: [Node (Lexeme Text)] -> Text
genArgs :: [Node (Lexeme Text)] -> Text
genArgs [Node (Lexeme Text)]
args = Text -> [Text] -> Text
Text.intercalate Text
" -> " ((Node (Lexeme Text) -> Text) -> [Node (Lexeme Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Text
genArg [Node (Lexeme Text)]
args) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> "


genFunction :: Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Text
genFunction :: Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Text
genFunction Node (Lexeme Text)
retTy Text
name [(Fix (TyStd (L AlexPosn
_ LexemeClass
KwVoid Text
_)))] =
    Text
"foreign import ccall " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Node (Lexeme Text) -> Text
genType Node (Lexeme Text)
retTy
genFunction Node (Lexeme Text)
retTy Text
name [Node (Lexeme Text)]
args =
    Text
"foreign import ccall " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Node (Lexeme Text)] -> Text
genArgs [Node (Lexeme Text)]
args Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"IO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
maybeParen (Node (Lexeme Text) -> Text
genType Node (Lexeme Text)
retTy)


genFuncType :: Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Text
genFuncType :: Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Text
genFuncType Node (Lexeme Text)
retTy Text
name [Node (Lexeme Text)]
args = [Text] -> Text
joinLines
    [ Text
"type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Node (Lexeme Text)] -> Text
genArgs [Node (Lexeme Text)]
args Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"IO " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
maybeParen (Node (Lexeme Text) -> Text
genType Node (Lexeme Text)
retTy)
    , Text
"foreign import ccall \"wrapper\" wrap" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" :: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> IO (FunPtr " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hsName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    ]
  where
    hsName :: Text
hsName = Text -> Text
idToHaskell Text
name


genEnumerator :: Node (Lexeme Text) -> Maybe Text
genEnumerator :: Node (Lexeme Text) -> Maybe Text
genEnumerator (Fix Comment{})                   = Maybe Text
forall a. Maybe a
Nothing
genEnumerator (Fix (Enumerator (L AlexPosn
_ LexemeClass
_ Text
name) Maybe (Node (Lexeme Text))
_)) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
idToHaskell Text
name
genEnumerator Node (Lexeme Text)
x                                 = String -> Maybe Text
forall a. HasCallStack => String -> a
error (String -> Maybe Text) -> String -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Node (Lexeme Text) -> String
forall a. Show a => a -> String
show Node (Lexeme Text)
x


genEnum :: Text -> [Node (Lexeme Text)] -> Text
genEnum :: Text -> [Node (Lexeme Text)] -> Text
genEnum Text
name [Node (Lexeme Text)]
enums = [Text] -> Text
joinLines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [ Text
"data " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
idToHaskell Text
name
    , Text
"    = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"\n    | " ([Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ((Node (Lexeme Text) -> Maybe Text)
-> [Node (Lexeme Text)] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map Node (Lexeme Text) -> Maybe Text
genEnumerator [Node (Lexeme Text)]
enums))
    , Text
"    deriving (Eq, Ord, Enum, Bounded, Read, Show)"
    ]


linter :: AstActions (State [Text]) Text
linter :: AstActions (State [Text]) Text
linter = AstActions (State [Text]) Text
forall (f :: * -> *) text. Applicative f => AstActions f text
astActions
    { doNode :: String -> Node (Lexeme Text) -> State [Text] () -> State [Text] ()
doNode = \String
_file Node (Lexeme Text)
node State [Text] ()
act ->
        case Node (Lexeme Text) -> NodeF (Lexeme Text) (Node (Lexeme Text))
forall (f :: * -> *). Fix f -> f (Fix f)
unFix Node (Lexeme Text)
node of
            FunctionDecl Scope
_ (Fix (FunctionPrototype Node (Lexeme Text)
retTy (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
args)) ->
                ([Text] -> [Text]) -> State [Text] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Text
genFunction Node (Lexeme Text)
retTy Text
name [Node (Lexeme Text)]
argsText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
            TypedefFunction (Fix (FunctionPrototype Node (Lexeme Text)
retTy (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
args)) ->
                ([Text] -> [Text]) -> State [Text] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Node (Lexeme Text) -> Text -> [Node (Lexeme Text)] -> Text
genFuncType Node (Lexeme Text)
retTy Text
name [Node (Lexeme Text)]
argsText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
            EnumDecl (L AlexPosn
_ LexemeClass
_ Text
name) [Node (Lexeme Text)]
enums Lexeme Text
_ ->
                ([Text] -> [Text]) -> State [Text] ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
State.modify (Text -> [Node (Lexeme Text)] -> Text
genEnum Text
name [Node (Lexeme Text)]
enumsText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)

            NodeF (Lexeme Text) (Node (Lexeme Text))
_ -> State [Text] ()
act
    }


generate :: (FilePath, [Node (Lexeme Text)]) -> (FilePath, Text)
generate :: (String, [Node (Lexeme Text)]) -> (String, Text)
generate = (String
"file.hs",) (Text -> (String, Text))
-> ((String, [Node (Lexeme Text)]) -> Text)
-> (String, [Node (Lexeme Text)])
-> (String, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
joinLines ([Text] -> Text)
-> ((String, [Node (Lexeme Text)]) -> [Text])
-> (String, [Node (Lexeme Text)])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text])
-> ((String, [Node (Lexeme Text)]) -> [Text])
-> (String, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (State [Text] () -> [Text] -> [Text])
-> [Text] -> State [Text] () -> [Text]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State [Text] () -> [Text] -> [Text]
forall s a. State s a -> s -> s
State.execState [] (State [Text] () -> [Text])
-> ((String, [Node (Lexeme Text)]) -> State [Text] ())
-> (String, [Node (Lexeme Text)])
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstActions (State [Text]) Text
-> (String, [Node (Lexeme Text)]) -> State [Text] ()
forall text a (f :: * -> *).
(TraverseAst text a, Applicative f) =>
AstActions f text -> a -> f ()
traverseAst AstActions (State [Text]) Text
linter