Target.hs

{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Poppy.Codegen.Target
  ( simpleTarget,
    CodegenTarget,
    GenOutput (..),
    targetOutputs,
    targetSchemas,
  )
where

import Data.Char (isAlphaNum, isUpper)
import Data.Maybe (isNothing)
import Data.Text (Text)
import qualified Data.Text as T
import Poppy.Codegen.Emit.Client
  ( emitClientModule,
  )
import Poppy.Codegen.Emit.Include (emitIncludeModule)
import Poppy.Codegen.Emit.Schema (emitEnumModule, emitModelModule)
import Poppy.Codegen.IR
  ( EnumSpec (..),
    Model (..),
    Schema (..),
    enumImport,
    enumName,
    modelName,
    modelRelations,
    schemaEnums,
    schemaModels,
  )
import System.FilePath (dropTrailingPathSeparator, splitDirectories, (</>))

-- | Path is relative to the process working directory.
data GenOutput = GenOutput
  { outputPath :: FilePath,
    outputText :: Text
  }

data SchemaLayout = SchemaLayout
  { slModulePrefix :: Text,
    slOutputDir :: FilePath
  }

data ClientLayout = ClientLayout
  { clModulePrefix :: Text,
    clOutputDir :: FilePath
  }

data CodegenTarget = CodegenTarget
  { ctSchemas :: [Schema],
    ctLayout :: SchemaLayout,
    ctClientLayout :: ClientLayout
  }

-- | Table types at @Prefix.Model@, clients at @Prefix.Client.Model@.
--
-- @Prefix@ is the path with non-module segments dropped (@src/Schema@ →
-- @Schema@).
simpleTarget :: FilePath -> Schema -> CodegenTarget
simpleTarget dir schema =
  let prefix = prefixFromDir dir
   in CodegenTarget
        { ctSchemas = [schema],
          ctLayout = SchemaLayout (prefix <> ".") dir,
          ctClientLayout =
            ClientLayout
              { clModulePrefix = prefix <> ".Client.",
                clOutputDir = dir </> "Client"
              }
        }

prefixFromDir :: FilePath -> Text
prefixFromDir dir =
  case filter isModuleSegment (map T.pack (splitDirectories (dropTrailingPathSeparator dir))) of
    [] ->
      error $
        "simpleTarget: "
          <> dir
          <> " has no Haskell module segment (e.g. src/Schema)"
    parts -> T.intercalate "." parts

isModuleSegment :: Text -> Bool
isModuleSegment name =
  case T.uncons name of
    Just (c, rest) -> isUpper c && T.all isModuleChar rest
    Nothing -> False

isModuleChar :: Char -> Bool
isModuleChar c = isAlphaNum c || c == '_' || c == '\''

targetSchemas :: [CodegenTarget] -> [Schema]
targetSchemas = concatMap (.ctSchemas)

targetOutputs :: CodegenTarget -> [GenOutput]
targetOutputs target =
  concatMap (schemaOutputs target) target.ctSchemas

schemaOutputs :: CodegenTarget -> Schema -> [GenOutput]
schemaOutputs target schema =
  enumOutputs target schema
    ++ modelOutputs target schema
    ++ includeOutputs target schema
    ++ clientOutputs target schema

enumOutputs :: CodegenTarget -> Schema -> [GenOutput]
enumOutputs target schema =
  concat
    [ enumOutput target enum
      | enum <- schemaEnums schema,
        isNothing (enumImport enum)
    ]

enumOutput :: CodegenTarget -> EnumSpec -> [GenOutput]
enumOutput target enum =
  let layout = target.ctLayout
      name = enumName enum
      moduleName = layout.slModulePrefix <> name
      path = layout.slOutputDir </> T.unpack name <> ".hs"
   in [gen path (emitEnumModule moduleName enum)]

modelOutputs :: CodegenTarget -> Schema -> [GenOutput]
modelOutputs target schema =
  concatMap (modelOutput target schema) (schemaModels schema)

modelOutput :: CodegenTarget -> Schema -> Model -> [GenOutput]
modelOutput target schema model =
  let layout = target.ctLayout
      name = modelName model
      moduleName = layout.slModulePrefix <> name
      path = layout.slOutputDir </> T.unpack name <> ".hs"
   in [gen path (emitModelModule moduleName schema model)]

includeOutputs :: CodegenTarget -> Schema -> [GenOutput]
includeOutputs target schema =
  concatMap (includeOutput target schema) (filter (not . null . modelRelations) (schemaModels schema))

includeOutput :: CodegenTarget -> Schema -> Model -> [GenOutput]
includeOutput target schema model =
  let layout = target.ctLayout
      name = modelName model
      moduleName = layout.slModulePrefix <> "Include." <> name
      path = layout.slOutputDir </> "Include" </> T.unpack name <> ".hs"
   in [gen path (emitIncludeModule moduleName schema model)]

clientOutputs :: CodegenTarget -> Schema -> [GenOutput]
clientOutputs target schema =
  concatMap (clientOutput target.ctClientLayout schema) (schemaModels schema)

clientOutput :: ClientLayout -> Schema -> Model -> [GenOutput]
clientOutput layout schema model =
  let name = modelName model
      moduleName = layout.clModulePrefix <> name
      path = layout.clOutputDir </> T.unpack name <> ".hs"
   in [gen path (emitClientModule moduleName schema model)]

gen :: FilePath -> Text -> GenOutput
gen path text = GenOutput {outputPath = path, outputText = text}