Emit.hs

-- | Haskell code generation from the API IR.
--
-- Produces a complete Haskell module with:
-- * Path types using GHC.TypeLits
-- * Request/response data types with FromJSON/ToJSON
-- * The API type as a promoted list
-- * Requires Auth on secured endpoints
module Acolyte.Codegen.Emit
  ( emitModule
  , EmitConfig (..)
  , defaultEmitConfig
  ) where

import Data.Char (toUpper, toLower, isAlpha, isAlphaNum)
import Data.List (intercalate, nub)
import Data.Text (Text)
import qualified Data.Text as T

import Acolyte.Codegen.IR


-- | Configuration for code emission.
data EmitConfig = EmitConfig
  { emitModuleName :: !Text     -- ^ Module name (e.g., "Generated.API")
  , emitHandlerStubs :: !Bool   -- ^ Generate handler stubs?
  } deriving (Show)

-- | Default emit configuration: module name @"Generated.API"@ with handler stubs enabled.
defaultEmitConfig :: EmitConfig
defaultEmitConfig = EmitConfig
  { emitModuleName   = "Generated.API"
  , emitHandlerStubs = True
  }


-- | Generate a complete Haskell module from an API IR.
emitModule :: EmitConfig -> ApiIR -> Text
emitModule cfg api = T.unlines $ concat
  [ emitHeader cfg api
  , [""]
  , emitImports
  , [""]
  , emitSchemaTypes (apiSchemas api)
  , [""]
  , emitPathTypes (apiEndpoints api)
  , [""]
  , emitApiType (apiEndpoints api)
  , if emitHandlerStubs cfg
    then [""] ++ emitStubs (apiEndpoints api)
    else []
  ]


-- ===================================================================
-- Header
-- ===================================================================

emitHeader :: EmitConfig -> ApiIR -> [Text]
emitHeader cfg api =
  [ "-- | Generated from: " <> apiTitle api <> " v" <> apiVersion api
  , "--"
  , "-- This module was auto-generated by acolyte-codegen."
  , "-- Edit the OpenAPI spec and re-run the generator to update."
  , "{-# LANGUAGE DataKinds #-}"
  , "{-# LANGUAGE TypeFamilies #-}"
  , "{-# LANGUAGE TypeOperators #-}"
  , "{-# LANGUAGE OverloadedStrings #-}"
  , "{-# LANGUAGE DeriveGeneric #-}"
  , "{-# LANGUAGE DeriveAnyClass #-}"
  , "module " <> emitModuleName cfg <> " where"
  ]


-- ===================================================================
-- Imports
-- ===================================================================

emitImports :: [Text]
emitImports =
  [ "import Data.Aeson (FromJSON, ToJSON)"
  , "import Data.Text (Text)"
  , "import GHC.Generics (Generic)"
  , "import Acolyte.Core"
  , "import Acolyte.Server (Json, HandlerFn)"
  ]


-- ===================================================================
-- Schema types (data declarations)
-- ===================================================================

emitSchemaTypes :: [(Text, SchemaIR)] -> [Text]
emitSchemaTypes schemas = concatMap emitSchemaType named
  where
    named = [ (n, s) | (n, s@(SchemaObject _ fields)) <- schemas, not (null fields) ]

emitSchemaType :: (Text, SchemaIR) -> [Text]
emitSchemaType (name, SchemaObject _ fields) =
  [ "data " <> typeName name <> " = " <> typeName name
  , "  { " <> T.intercalate "\n  , " (map emitField fields)
  , "  } deriving (Show, Eq, Generic, FromJSON, ToJSON)"
  , ""
  ]
emitSchemaType _ = []

emitField :: FieldIR -> Text
emitField f =
  fieldAccessor (fieldName f) <> " :: " <> emitSchemaTypeRef (fieldSchema f)

fieldAccessor :: Text -> Text
fieldAccessor name = T.pack (camelCase (T.unpack name))

emitSchemaTypeRef :: SchemaIR -> Text
emitSchemaTypeRef SchemaString     = "Text"
emitSchemaTypeRef SchemaInteger    = "Int"
emitSchemaTypeRef SchemaNumber     = "Double"
emitSchemaTypeRef SchemaBoolean    = "Bool"
emitSchemaTypeRef (SchemaArray s)  = "[" <> emitSchemaTypeRef s <> "]"
emitSchemaTypeRef (SchemaRef name) = typeName name
emitSchemaTypeRef (SchemaObject n _) = typeName n


-- ===================================================================
-- Path types
-- ===================================================================

emitPathTypes :: [EndpointIR] -> [Text]
emitPathTypes eps = map emitPathType (nub (map pathId eps))
  where
    pathId ep = (pathTypeName (epPath ep), epPath ep)

    emitPathType (name, segments) =
      "type " <> name <> " = '[" <> T.intercalate ", " (map emitSegment segments) <> "]"


emitSegment :: PathSegmentIR -> Text
emitSegment (LitSegment s)       = "'Lit \"" <> s <> "\""
emitSegment (CaptureSegment _ t) = "'Capture " <> captureType t

captureType :: Text -> Text
captureType "integer" = "Int"
captureType "number"  = "Double"
captureType _         = "Text"


pathTypeName :: [PathSegmentIR] -> Text
pathTypeName segments = T.pack $ concatMap segName segments ++ "Path"
  where
    segName (LitSegment s)       = pascal (T.unpack s)
    segName (CaptureSegment n _) = "By" ++ pascal (T.unpack n)


-- ===================================================================
-- API type
-- ===================================================================

emitApiType :: [EndpointIR] -> [Text]
emitApiType [] = ["type API = '[]"]
emitApiType eps =
  [ "type API ="
  , "  '[ " <> T.intercalate "\n   , " (map emitEndpoint eps)
  , "   ]"
  ]

emitEndpoint :: EndpointIR -> Text
emitEndpoint ep =
  let core = emitCoreEndpoint ep
  in if epRequiresAuth ep
     then "Requires Auth (" <> core <> ")"
     else core

emitCoreEndpoint :: EndpointIR -> Text
emitCoreEndpoint ep =
  let pathName = pathTypeName (epPath ep)
      respType = maybe "Text" emitResponseType (epResponseType ep)
  in case epMethod ep of
    GET    -> "Get " <> pathName <> " (Json " <> respType <> ")"
    DELETE -> "Delete " <> pathName <> " (Json " <> respType <> ")"
    POST   -> "Post " <> pathName <> " " <> emitReqType ep <> " (Json " <> respType <> ")"
    PUT    -> "Put " <> pathName <> " " <> emitReqType ep <> " (Json " <> respType <> ")"
    PATCH  -> "Patch " <> pathName <> " " <> emitReqType ep <> " (Json " <> respType <> ")"
    HEAD   -> "Get " <> pathName <> " (Json " <> respType <> ")"
    OPTIONS -> "Get " <> pathName <> " (Json " <> respType <> ")"

emitReqType :: EndpointIR -> Text
emitReqType ep = case epRequestBody ep of
  Just (SchemaRef name) -> "(Json " <> typeName name <> ")"
  Just _                -> "(Json Value)"
  Nothing               -> "(Json Value)"

emitResponseType :: SchemaIR -> Text
emitResponseType (SchemaRef name)   = typeName name
emitResponseType (SchemaArray s)    = "[" <> emitResponseType s <> "]"
emitResponseType SchemaString       = "Text"
emitResponseType SchemaInteger      = "Int"
emitResponseType SchemaNumber       = "Double"
emitResponseType SchemaBoolean      = "Bool"
emitResponseType (SchemaObject n _) = typeName n


-- ===================================================================
-- Handler stubs
-- ===================================================================

emitStubs :: [EndpointIR] -> [Text]
emitStubs eps =
  [ "-- ====================================================================="
  , "-- Handler stubs (implement these)"
  , "-- ====================================================================="
  , ""
  ] ++ concatMap emitStub eps

emitStub :: EndpointIR -> [Text]
emitStub ep =
  let name = stubName ep
  in [ "-- " <> T.pack (show (epMethod ep)) <> " " <> reconstructPath (epPath ep)
     , name <> " :: HandlerFn"
     , name <> " _parts _body = error \"TODO: implement " <> name <> "\""
     , ""
     ]

stubName :: EndpointIR -> Text
stubName ep = T.pack $ camelCase $
  map toLower (show (epMethod ep)) ++ concatMap segWord (epPath ep)
  where
    segWord (LitSegment s) = pascal (T.unpack s)
    segWord (CaptureSegment n _) = "By" ++ pascal (T.unpack n)

reconstructPath :: [PathSegmentIR] -> Text
reconstructPath segs = "/" <> T.intercalate "/" (map segText segs)
  where
    segText (LitSegment s) = s
    segText (CaptureSegment n _) = "{" <> n <> "}"


-- ===================================================================
-- String utilities
-- ===================================================================

typeName :: Text -> Text
typeName = T.pack . pascal . T.unpack

pascal :: String -> String
pascal [] = []
pascal (c:cs) = toUpper c : cs

camelCase :: String -> String
camelCase [] = []
camelCase (c:cs) = toLower c : cs