{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Convex.Parser (parseProject, parseProjectFromContents, ParsedProject (..), apiFileParser, runUnificationPass) where

import Control.Monad (forM, void)
import qualified Convex.Action.Parser as Action
import qualified Convex.Schema.Parser as Schema
import Data.Char (toUpper)
import Data.List (sort, sortOn)
import qualified Data.Map as Map
import System.FilePath (replaceExtension, (</>))
import Text.Parsec
import Text.Parsec.Language (emptyDef)
import qualified Text.Parsec.Token as Token

data ParsedProject = ParsedProject
  { ParsedProject -> Schema
ppSchema :: Schema.Schema,
    ParsedProject -> Map String ConvexType
ppConstants :: Map.Map String Schema.ConvexType,
    ParsedProject -> [ConvexFunction]
ppFunctions :: [Action.ConvexFunction]
  }
  deriving (Int -> ParsedProject -> ShowS
[ParsedProject] -> ShowS
ParsedProject -> String
(Int -> ParsedProject -> ShowS)
-> (ParsedProject -> String)
-> ([ParsedProject] -> ShowS)
-> Show ParsedProject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParsedProject -> ShowS
showsPrec :: Int -> ParsedProject -> ShowS
$cshow :: ParsedProject -> String
show :: ParsedProject -> String
$cshowList :: [ParsedProject] -> ShowS
showList :: [ParsedProject] -> ShowS
Show, ParsedProject -> ParsedProject -> Bool
(ParsedProject -> ParsedProject -> Bool)
-> (ParsedProject -> ParsedProject -> Bool) -> Eq ParsedProject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParsedProject -> ParsedProject -> Bool
== :: ParsedProject -> ParsedProject -> Bool
$c/= :: ParsedProject -> ParsedProject -> Bool
/= :: ParsedProject -> ParsedProject -> Bool
Eq)

apiLexer :: Token.TokenParser ()
apiLexer :: TokenParser ()
apiLexer =
  GenLanguageDef String () Identity -> TokenParser ()
forall s (m :: * -> *) u.
Stream s m Char =>
GenLanguageDef s u m -> GenTokenParser s u m
Token.makeTokenParser
    GenLanguageDef String () Identity
forall st. LanguageDef st
emptyDef
      { Token.identStart = letter <|> char '_',
        Token.identLetter = alphaNum <|> char '_',
        Token.reservedNames = ["typeof", "declare", "const", "ApiFromModules"]
      }

apiStringLiteral :: Parsec String () String
apiStringLiteral :: Parsec String () String
apiStringLiteral = TokenParser () -> Parsec String () String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
Token.stringLiteral TokenParser ()
apiLexer

apiIdentifier :: Parsec String () String
apiIdentifier :: Parsec String () String
apiIdentifier = TokenParser () -> Parsec String () String
forall s u (m :: * -> *).
GenTokenParser s u m -> ParsecT s u m String
Token.identifier TokenParser ()
apiLexer

apiReserved :: String -> Parsec String () ()
apiReserved :: String -> Parsec String () ()
apiReserved = TokenParser () -> String -> Parsec String () ()
forall s u (m :: * -> *).
GenTokenParser s u m -> String -> ParsecT s u m ()
Token.reserved TokenParser ()
apiLexer

apiFileParser :: Parsec String () [String] -- We only need the paths
apiFileParser :: Parsec String () [String]
apiFileParser = do
  -- Find the start of the object we care about
  Parsec String () String -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parsec String () String -> Parsec String () ())
-> Parsec String () String -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity Char
-> Parsec String () String -> Parsec String () String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar (Parsec String () String -> Parsec String () String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (String -> Parsec String () String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"declare const fullApi: ApiFromModules<"))
  -- Enter the braces of the object
  [String]
paths <- TokenParser ()
-> forall a.
   ParsecT String () Identity a -> ParsecT String () Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
Token.braces TokenParser ()
apiLexer (Parsec String () String
-> ParsecT String () Identity Char -> Parsec String () [String]
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
sepEndBy Parsec String () String
singlePath (TokenParser ()
-> forall a.
   ParsecT String () Identity a -> ParsecT String () Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
Token.lexeme TokenParser ()
apiLexer (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';')))
  [String] -> Parsec String () [String]
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
paths
  where
    -- This parses a single line like: "admin/actions": typeof admin_actions
    singlePath :: Parsec String () String
singlePath = do
      String
path <- Parsec String () String
apiStringLiteral Parsec String () String
-> Parsec String () String -> Parsec String () String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec String () String
apiIdentifier
      ParsecT String () Identity Char -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT String () Identity Char -> Parsec String () ())
-> ParsecT String () Identity Char -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ TokenParser ()
-> forall a.
   ParsecT String () Identity a -> ParsecT String () Identity a
forall s u (m :: * -> *).
GenTokenParser s u m
-> forall a. ParsecT s u m a -> ParsecT s u m a
Token.lexeme TokenParser ()
apiLexer (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
      Parsec String () () -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parsec String () () -> Parsec String () ())
-> Parsec String () () -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ String -> Parsec String () ()
apiReserved String
"typeof"
      Parsec String () String -> Parsec String () ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parsec String () String -> Parsec String () ())
-> Parsec String () String -> Parsec String () ()
forall a b. (a -> b) -> a -> b
$ Parsec String () String
apiIdentifier -- Consume the alias, we don't need it
      String -> Parsec String () String
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path

parseProjectFromContents ::
  String ->
  String ->
  [(String, String)] ->
  IO (Either String ParsedProject)
parseProjectFromContents :: String
-> String -> [(String, String)] -> IO (Either String ParsedProject)
parseProjectFromContents String
schemaContent String
apiFileContent [(String, String)]
actionContents = do
  -- 1. Parse Schema
  Either ParseError ParsedFile
schemaResult <- String -> IO (Either ParseError ParsedFile)
Schema.parseSchema String
schemaContent
  case Either ParseError ParsedFile
schemaResult of
    Left ParseError
err -> Either String ParsedProject -> IO (Either String ParsedProject)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ParsedProject -> IO (Either String ParsedProject))
-> Either String ParsedProject -> IO (Either String ParsedProject)
forall a b. (a -> b) -> a -> b
$ String -> Either String ParsedProject
forall a b. a -> Either a b
Left (String
"Failed to parse schema.ts: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err)
    Right ParsedFile
schemaFile -> do
      let initialState :: ParserState
initialState = Schema.ParserState {psConstants :: Map String ConvexType
Schema.psConstants = ParsedFile -> Map String ConvexType
Schema.parsedConstants ParsedFile
schemaFile}

      -- Parse API file to get module paths
      let modulePaths :: [String]
modulePaths = case Parsec String () [String]
-> String -> String -> Either ParseError [String]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [String]
apiFileParser String
"(api.d.ts)" String
apiFileContent of
            Left ParseError
_ -> [] -- Or should this be an error? The original returns []
            Right [String]
paths -> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"schema") [String]
paths

      let actionContentMap :: Map String String
actionContentMap = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
actionContents

      -- Parse action files
      [ConvexFunction]
allFunctions <- ([[ConvexFunction]] -> [ConvexFunction])
-> IO [[ConvexFunction]] -> IO [ConvexFunction]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ConvexFunction]] -> [ConvexFunction]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[ConvexFunction]] -> IO [ConvexFunction])
-> ((String -> IO [ConvexFunction]) -> IO [[ConvexFunction]])
-> (String -> IO [ConvexFunction])
-> IO [ConvexFunction]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String]
-> (String -> IO [ConvexFunction]) -> IO [[ConvexFunction]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
modulePaths ((String -> IO [ConvexFunction]) -> IO [ConvexFunction])
-> (String -> IO [ConvexFunction]) -> IO [ConvexFunction]
forall a b. (a -> b) -> a -> b
$ \String
modulePath -> do
        let astPath :: String
astPath = String -> ShowS
replaceExtension String
modulePath String
""
        case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
modulePath Map String String
actionContentMap of
          Maybe String
Nothing -> do
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Action content not found for module: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
modulePath
            [ConvexFunction] -> IO [ConvexFunction]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Just String
actionContent -> do
            Either ParseError [ConvexFunction]
actionResult <- ParsecT String ParserState IO [ConvexFunction]
-> ParserState
-> String
-> String
-> IO (Either ParseError [ConvexFunction])
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT (String -> ParsecT String ParserState IO [ConvexFunction]
Action.parseActionFile String
astPath) ParserState
initialState String
modulePath String
actionContent
            case Either ParseError [ConvexFunction]
actionResult of
              Left ParseError
err -> do
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse actions from: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
modulePath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" | Error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
                [ConvexFunction] -> IO [ConvexFunction]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
              Right [ConvexFunction]
funcs -> do
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Parsed actions from: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
modulePath
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show ([ConvexFunction] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConvexFunction]
funcs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" functions found"
                [ConvexFunction] -> IO [ConvexFunction]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ConvexFunction]
funcs

      -- Construct and unify project
      let project :: ParsedProject
project =
            ParsedProject
              { ppSchema :: Schema
ppSchema = ParsedFile -> Schema
Schema.parsedSchema ParsedFile
schemaFile,
                ppConstants :: Map String ConvexType
ppConstants = ParsedFile -> Map String ConvexType
Schema.parsedConstants ParsedFile
schemaFile,
                ppFunctions :: [ConvexFunction]
ppFunctions = [ConvexFunction]
allFunctions
              }

      Either String ParsedProject -> IO (Either String ParsedProject)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ParsedProject -> IO (Either String ParsedProject))
-> (ParsedProject -> Either String ParsedProject)
-> ParsedProject
-> IO (Either String ParsedProject)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedProject -> Either String ParsedProject
forall a b. b -> Either a b
Right (ParsedProject -> Either String ParsedProject)
-> (ParsedProject -> ParsedProject)
-> ParsedProject
-> Either String ParsedProject
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedProject -> ParsedProject
runUnificationPass (ParsedProject -> IO (Either String ParsedProject))
-> ParsedProject -> IO (Either String ParsedProject)
forall a b. (a -> b) -> a -> b
$ ParsedProject
project

parseProject :: FilePath -> FilePath -> IO (Either String ParsedProject)
parseProject :: String -> String -> IO (Either String ParsedProject)
parseProject String
schemaPath String
declRootDir = do
  -- Parse the source schema file first to get tables and the initial state with constants.
  String
schemaContent <- String -> IO String
readFile String
schemaPath
  -- Parse the _generated/api.d.ts file to discover function modules.
  let apiFilePath :: String
apiFilePath = String
declRootDir String -> ShowS
</> String
"_generated" String -> ShowS
</> String
"api.d.ts"
  String
apiFileContent <- String -> IO String
readFile String
apiFilePath
  let modulePaths :: [String]
modulePaths = case Parsec String () [String]
-> String -> String -> Either ParseError [String]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [String]
apiFileParser String
apiFilePath String
apiFileContent of
        Left ParseError
_ -> []
        Right [String]
paths -> (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"schema") [String]
paths

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Found " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
modulePaths) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" action modules in: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
apiFilePath

  -- For each discovered module, parse its corresponding .d.ts file.
  [(String, String)]
actionContents <- [String]
-> (String -> IO (String, String)) -> IO [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
modulePaths ((String -> IO (String, String)) -> IO [(String, String)])
-> (String -> IO (String, String)) -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \String
modulePath -> do
    let fullPath :: String
fullPath = String
declRootDir String -> ShowS
</> String -> ShowS
replaceExtension String
modulePath String
".d.ts"
    String
content <- String -> IO String
readFile String
fullPath
    (String, String) -> IO (String, String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
modulePath, String
content)

  String
-> String -> [(String, String)] -> IO (Either String ParsedProject)
parseProjectFromContents String
schemaContent String
apiFileContent [(String, String)]
actionContents

type UnionSignatureMap = Map.Map [String] String

type ObjectSignatureMap = Map.Map [(String, Schema.ConvexType)] String

-- | Pre-processes the parsed project to replace anonymous unions and objects
-- with named references if they structurally match. This is done iteratively
-- to a fixed point to handle nested structures.
runUnificationPass :: ParsedProject -> ParsedProject
runUnificationPass :: ParsedProject -> ParsedProject
runUnificationPass ParsedProject
project =
  let ephemeralProject :: ParsedProject
ephemeralProject = ParsedProject -> ParsedProject
addTableDocsToConstants ParsedProject
project
      unifiedProject :: ParsedProject
unifiedProject = ParsedProject -> ParsedProject
go ParsedProject
ephemeralProject
   in ParsedProject
unifiedProject {ppConstants = ppConstants project} -- Discard ephemeral constants
  where
    go :: ParsedProject -> ParsedProject
go ParsedProject
currentProject =
      let nextProject :: ParsedProject
nextProject = ParsedProject -> ParsedProject
unifyOnce ParsedProject
currentProject
       in if ParsedProject
nextProject ParsedProject -> ParsedProject -> Bool
forall a. Eq a => a -> a -> Bool
== ParsedProject
currentProject
            then ParsedProject
currentProject
            else ParsedProject -> ParsedProject
go ParsedProject
nextProject

canonicalizeType :: Schema.ConvexType -> Schema.ConvexType
canonicalizeType :: ConvexType -> ConvexType
canonicalizeType (Schema.VObject [(String, ConvexType)]
fields) =
  [(String, ConvexType)] -> ConvexType
Schema.VObject ([(String, ConvexType)] -> ConvexType)
-> ([(String, ConvexType)] -> [(String, ConvexType)])
-> [(String, ConvexType)]
-> ConvexType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, ConvexType) -> String)
-> [(String, ConvexType)] -> [(String, ConvexType)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, ConvexType) -> String
forall a b. (a, b) -> a
fst ([(String, ConvexType)] -> [(String, ConvexType)])
-> ([(String, ConvexType)] -> [(String, ConvexType)])
-> [(String, ConvexType)]
-> [(String, ConvexType)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, ConvexType) -> (String, ConvexType))
-> [(String, ConvexType)] -> [(String, ConvexType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
n, ConvexType
t) -> (String
n, ConvexType -> ConvexType
canonicalizeType ConvexType
t)) ([(String, ConvexType)] -> ConvexType)
-> [(String, ConvexType)] -> ConvexType
forall a b. (a -> b) -> a -> b
$ [(String, ConvexType)]
fields
canonicalizeType (Schema.VUnion [ConvexType]
types) =
  [ConvexType] -> ConvexType
Schema.VUnion ([ConvexType] -> ConvexType)
-> ([ConvexType] -> [ConvexType]) -> [ConvexType] -> ConvexType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ConvexType] -> [ConvexType]
forall a. Ord a => [a] -> [a]
sort ([ConvexType] -> [ConvexType])
-> ([ConvexType] -> [ConvexType]) -> [ConvexType] -> [ConvexType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConvexType -> ConvexType) -> [ConvexType] -> [ConvexType]
forall a b. (a -> b) -> [a] -> [b]
map ConvexType -> ConvexType
canonicalizeType ([ConvexType] -> ConvexType) -> [ConvexType] -> ConvexType
forall a b. (a -> b) -> a -> b
$ [ConvexType]
types
canonicalizeType (Schema.VArray ConvexType
t) = ConvexType -> ConvexType
Schema.VArray (ConvexType -> ConvexType
canonicalizeType ConvexType
t)
canonicalizeType (Schema.VOptional ConvexType
t) = ConvexType -> ConvexType
Schema.VOptional (ConvexType -> ConvexType
canonicalizeType ConvexType
t)
canonicalizeType ConvexType
other = ConvexType
other

addTableDocsToConstants :: ParsedProject -> ParsedProject
addTableDocsToConstants :: ParsedProject -> ParsedProject
addTableDocsToConstants ParsedProject
project =
  let tableDocs :: Map String ConvexType
tableDocs =
        [(String, ConvexType)] -> Map String ConvexType
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ ( ShowS
toPascalCase (Table -> String
Schema.tableName Table
table) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Doc",
              [(String, ConvexType)] -> ConvexType
Schema.VObject ([(String, ConvexType)] -> ConvexType)
-> ([(String, ConvexType)] -> [(String, ConvexType)])
-> [(String, ConvexType)]
-> ConvexType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, ConvexType) -> String)
-> [(String, ConvexType)] -> [(String, ConvexType)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, ConvexType) -> String
forall a b. (a, b) -> a
fst ([(String, ConvexType)] -> ConvexType)
-> [(String, ConvexType)] -> ConvexType
forall a b. (a -> b) -> a -> b
$
                [(String
"_id", String -> ConvexType
Schema.VId (Table -> String
Schema.tableName Table
table)), (String
"_creationTime", ConvexType
Schema.VNumber)]
                  [(String, ConvexType)]
-> [(String, ConvexType)] -> [(String, ConvexType)]
forall a. [a] -> [a] -> [a]
++ (Field -> (String, ConvexType))
-> [Field] -> [(String, ConvexType)]
forall a b. (a -> b) -> [a] -> [b]
map
                    (\Field
f -> (Field -> String
Schema.fieldName Field
f, Field -> ConvexType
Schema.fieldType Field
f))
                    (Table -> [Field]
Schema.tableFields Table
table)
            )
          | Table
table <- Schema -> [Table]
Schema.getTables (ParsedProject -> Schema
ppSchema ParsedProject
project)
          ]
      allConstants :: Map String ConvexType
allConstants = Map String ConvexType
-> Map String ConvexType -> Map String ConvexType
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (ParsedProject -> Map String ConvexType
ppConstants ParsedProject
project) Map String ConvexType
tableDocs
   in ParsedProject
project {ppConstants = allConstants}

toPascalCase :: String -> String
toPascalCase :: ShowS
toPascalCase [] = []
toPascalCase (Char
h : String
t) = Char -> Char
toUpper Char
h Char -> ShowS
forall a. a -> [a] -> [a]
: String
t

buildUnionSignatureMap :: Map.Map String Schema.ConvexType -> UnionSignatureMap
buildUnionSignatureMap :: Map String ConvexType -> UnionSignatureMap
buildUnionSignatureMap Map String ConvexType
constants =
  [([String], String)] -> UnionSignatureMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (ConvexType -> String) -> [ConvexType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ConvexType -> String
Schema.getLiteralString [ConvexType]
literals, String
name)
    | (String
name, Schema.VUnion [ConvexType]
literals) <- Map String ConvexType -> [(String, ConvexType)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String ConvexType
constants,
      (ConvexType -> Bool) -> [ConvexType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConvexType -> Bool
Schema.isLiteral [ConvexType]
literals
    ]

buildObjectSignatureMap :: Map.Map String Schema.ConvexType -> ObjectSignatureMap
buildObjectSignatureMap :: Map String ConvexType -> ObjectSignatureMap
buildObjectSignatureMap Map String ConvexType
constants =
  [([(String, ConvexType)], String)] -> ObjectSignatureMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (((String, ConvexType) -> String)
-> [(String, ConvexType)] -> [(String, ConvexType)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (String, ConvexType) -> String
forall a b. (a, b) -> a
fst [(String, ConvexType)]
fields, String
name)
    | (String
name, Schema.VObject [(String, ConvexType)]
fields) <- Map String ConvexType -> [(String, ConvexType)]
forall k a. Map k a -> [(k, a)]
Map.toList Map String ConvexType
constants
    ]

unifyFunctionTypes :: (Schema.ConvexType -> Schema.ConvexType) -> Action.ConvexFunction -> Action.ConvexFunction
unifyFunctionTypes :: (ConvexType -> ConvexType) -> ConvexFunction -> ConvexFunction
unifyFunctionTypes ConvexType -> ConvexType
unifyType ConvexFunction
func =
  ConvexFunction
func
    { Action.funcArgs = map (\(String
name, ConvexType
t) -> (String
name, ConvexType -> ConvexType
unifyType ConvexType
t)) (Action.funcArgs func),
      Action.funcReturn = unifyType (Action.funcReturn func)
    }

unifyTypeRecursively :: Maybe String -> UnionSignatureMap -> ObjectSignatureMap -> Schema.ConvexType -> Schema.ConvexType
unifyTypeRecursively :: Maybe String
-> UnionSignatureMap
-> ObjectSignatureMap
-> ConvexType
-> ConvexType
unifyTypeRecursively Maybe String
mCurrentName UnionSignatureMap
unionMap ObjectSignatureMap
objectMap = ConvexType -> ConvexType
go
  where
    goRec :: ConvexType -> ConvexType
goRec = Maybe String
-> UnionSignatureMap
-> ObjectSignatureMap
-> ConvexType
-> ConvexType
unifyTypeRecursively Maybe String
forall a. Maybe a
Nothing UnionSignatureMap
unionMap ObjectSignatureMap
objectMap

    go :: ConvexType -> ConvexType
go u :: ConvexType
u@(Schema.VUnion [ConvexType]
literals)
      | (ConvexType -> Bool) -> [ConvexType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConvexType -> Bool
Schema.isLiteral [ConvexType]
literals =
          let signature :: [String]
signature = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (ConvexType -> String) -> [ConvexType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ConvexType -> String
Schema.getLiteralString [ConvexType]
literals
           in case [String] -> UnionSignatureMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [String]
signature UnionSignatureMap
unionMap of
                Just String
refName ->
                  if String -> Maybe String
forall a. a -> Maybe a
Just String
refName Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
mCurrentName
                    then ConvexType -> ConvexType
canonicalizeType ConvexType
u
                    else String -> ConvexType
Schema.VReference String
refName
                Maybe String
Nothing -> ConvexType -> ConvexType
canonicalizeType ConvexType
u
      | Bool
otherwise =
          let unifiedUnion :: ConvexType
unifiedUnion = [ConvexType] -> ConvexType
Schema.VUnion ((ConvexType -> ConvexType) -> [ConvexType] -> [ConvexType]
forall a b. (a -> b) -> [a] -> [b]
map ConvexType -> ConvexType
goRec [ConvexType]
literals)
           in ConvexType -> ConvexType
canonicalizeType ConvexType
unifiedUnion
    go (Schema.VObject [(String, ConvexType)]
fields) =
      let unifiedFields :: [(String, ConvexType)]
unifiedFields = ((String, ConvexType) -> (String, ConvexType))
-> [(String, ConvexType)] -> [(String, ConvexType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
name, ConvexType
t) -> (String
name, ConvexType -> ConvexType
goRec ConvexType
t)) [(String, ConvexType)]
fields
          canonicalAttempt :: ConvexType
canonicalAttempt = ConvexType -> ConvexType
canonicalizeType ([(String, ConvexType)] -> ConvexType
Schema.VObject [(String, ConvexType)]
unifiedFields)
       in case ConvexType
canonicalAttempt of
            Schema.VObject [(String, ConvexType)]
signature ->
              let canonicalObject :: ConvexType
canonicalObject = [(String, ConvexType)] -> ConvexType
Schema.VObject [(String, ConvexType)]
signature
               in case [(String, ConvexType)] -> ObjectSignatureMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [(String, ConvexType)]
signature ObjectSignatureMap
objectMap of
                    Just String
refName ->
                      if String -> Maybe String
forall a. a -> Maybe a
Just String
refName Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
mCurrentName
                        then ConvexType
canonicalObject
                        else String -> ConvexType
Schema.VReference String
refName
                    Maybe String
Nothing -> ConvexType
canonicalObject
            ConvexType
_ -> ConvexType
canonicalAttempt -- Should not happen, but safer
    go (Schema.VArray ConvexType
inner) = ConvexType -> ConvexType
Schema.VArray (ConvexType -> ConvexType
goRec ConvexType
inner)
    go (Schema.VOptional ConvexType
inner) = ConvexType -> ConvexType
Schema.VOptional (ConvexType -> ConvexType
goRec ConvexType
inner)
    go ConvexType
otherType = ConvexType
otherType

unifyOnce :: ParsedProject -> ParsedProject
unifyOnce :: ParsedProject -> ParsedProject
unifyOnce ParsedProject
project =
  let unionMap :: UnionSignatureMap
unionMap = Map String ConvexType -> UnionSignatureMap
buildUnionSignatureMap (ParsedProject -> Map String ConvexType
ppConstants ParsedProject
project)
      initialObjectMap :: ObjectSignatureMap
initialObjectMap = Map String ConvexType -> ObjectSignatureMap
buildObjectSignatureMap (ParsedProject -> Map String ConvexType
ppConstants ParsedProject
project)

      -- First, unify the constants themselves. This resolves nested anonymous objects
      -- within the constants first, creating a canonical representation for this pass.
      unifiedConstants :: Map String ConvexType
unifiedConstants =
        (String -> ConvexType -> ConvexType)
-> Map String ConvexType -> Map String ConvexType
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\String
k -> Maybe String
-> UnionSignatureMap
-> ObjectSignatureMap
-> ConvexType
-> ConvexType
unifyTypeRecursively (String -> Maybe String
forall a. a -> Maybe a
Just String
k) UnionSignatureMap
unionMap ObjectSignatureMap
initialObjectMap) (ParsedProject -> Map String ConvexType
ppConstants ParsedProject
project)

      -- Now, build the object map for function unification from these *newly unified* constants.
      -- This map contains the canonical object structures for this pass.
      finalObjectMap :: ObjectSignatureMap
finalObjectMap = Map String ConvexType -> ObjectSignatureMap
buildObjectSignatureMap Map String ConvexType
unifiedConstants

      -- Create the unification function for anonymous types found in function signatures.
      unifyAnonType :: ConvexType -> ConvexType
unifyAnonType = Maybe String
-> UnionSignatureMap
-> ObjectSignatureMap
-> ConvexType
-> ConvexType
unifyTypeRecursively Maybe String
forall a. Maybe a
Nothing UnionSignatureMap
unionMap ObjectSignatureMap
finalObjectMap

      unifiedFunctions :: [ConvexFunction]
unifiedFunctions = (ConvexFunction -> ConvexFunction)
-> [ConvexFunction] -> [ConvexFunction]
forall a b. (a -> b) -> [a] -> [b]
map ((ConvexType -> ConvexType) -> ConvexFunction -> ConvexFunction
unifyFunctionTypes ConvexType -> ConvexType
unifyAnonType) (ParsedProject -> [ConvexFunction]
ppFunctions ParsedProject
project)
   in ParsedProject
project
        { ppConstants = unifiedConstants,
          ppFunctions = unifiedFunctions
        }