content: {-# LANGUAGE ApplicativeDo #-}
  
  module Axel.Normalize where
  
  import Axel.Prelude
  
  import Axel.AST
    ( CaseBlock(CaseBlock)
    , DataDeclaration(DataDeclaration)
    , Expression(ECaseBlock, EEmptySExpression, EFunctionApplication,
             EIdentifier, ELambda, ELetBlock, ELiteral, EPatternBinding,
             ERawExpression, ERecordDefinition, ERecordType)
    , FunctionApplication(FunctionApplication)
    , FunctionDefinition(FunctionDefinition)
    , Identifier
    , Import(ImportItem, ImportType)
    , ImportSpecification(ImportAll, ImportOnly)
    , Lambda(Lambda)
    , LetBlock(LetBlock)
    , Literal(LChar, LFloat, LInt, LString)
    , MacroDefinition(MacroDefinition)
    , MacroImport(MacroImport)
    , NewtypeDeclaration(NewtypeDeclaration)
    , PatternBinding(PatternBinding)
    , Pragma(Pragma)
    , QualifiedImport(QualifiedImport)
    , RecordDefinition(RecordDefinition)
    , RecordType(RecordType)
    , RestrictedImport(RestrictedImport)
    , SMStatement
    , Statement(SDataDeclaration, SFunctionDefinition, SMacroDefinition,
            SMacroImport, SModuleDeclaration, SNewtypeDeclaration, SPragma,
            SQualifiedImport, SRawStatement, SRestrictedImport, STopLevel,
            STypeSignature, STypeSynonym, STypeclassDefinition,
            STypeclassInstance)
    , TopLevel(TopLevel)
    , TypeDefinition(ProperType, TypeConstructor)
    , TypeSignature(TypeSignature)
    , TypeSynonym(TypeSynonym)
    , TypeclassDefinition(TypeclassDefinition)
    , TypeclassInstance(TypeclassInstance)
    )
  import Axel.Eff ((:>>))
  import Axel.Eff.Error (Error(NormalizeError), renderError, unsafeRunError)
  import Axel.Parse (unhygenisizeIdentifier)
  import qualified Axel.Parse.AST as Parse
    ( Expression(LiteralChar, LiteralFloat, LiteralInt, LiteralString,
             SExpression, Symbol)
    )
  import qualified Axel.Sourcemap as SM (Expression)
  
  import qualified Data.Text as T
  
  import Effectful ((:>))
  import qualified Effectful as Eff
  import qualified Effectful.Error.Static as Eff
  import qualified Effectful.Reader.Static as Eff
  
  type ExprCtxt = [SM.Expression]
  
  pushCtxt ::
       (Eff.Reader [SM.Expression] :> effs)
    => SM.Expression
    -> Eff.Eff effs a
    -> Eff.Eff effs a
  pushCtxt newCtxt = Eff.local (newCtxt :)
  
  withExprCtxt :: Eff.Eff (Eff.Reader [SM.Expression] ': effs) a -> Eff.Eff effs a
  withExprCtxt = Eff.runReader []
  
  throwNormalizeError ::
       ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs)
    => Text
    -> Eff.Eff effs a
  throwNormalizeError msg = do
    filePath <- Eff.ask @FilePath
    exprCtxt <- Eff.ask @ExprCtxt
    Eff.throwError $ NormalizeError filePath msg exprCtxt
  
  normalizeExpression ::
       ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs)
    => SM.Expression
    -> Eff.Eff effs (Expression (Maybe SM.Expression))
  normalizeExpression expr@(Parse.LiteralChar _ char) =
    pure $ ELiteral (LChar (Just expr) char)
  normalizeExpression expr@(Parse.LiteralFloat _ float) =
    pure $ ELiteral (LFloat (Just expr) float)
  normalizeExpression expr@(Parse.LiteralInt _ int) =
    pure $ ELiteral (LInt (Just expr) int)
  normalizeExpression expr@(Parse.LiteralString _ string) =
    pure $ ELiteral (LString (Just expr) (T.pack string))
  normalizeExpression expr@(Parse.SExpression _ items) =
    pushCtxt expr $
    case items of
      (Parse.Symbol sourceMetadata special):args ->
        case unhygenisizeIdentifier special of
          "case" ->
            case args of
              var:cases ->
                let normalizedCases =
                      traverse
                        (\case
                           Parse.SExpression _ [pat, body] ->
                             (,) <$> normalizeExpression pat <*>
                             normalizeExpression body
                           x ->
                             pushCtxt x $
                             throwNormalizeError
                               "A `case` clause must be an s-expression containing: 1) a pattern and 2) a body.")
                        cases
                 in ECaseBlock <$>
                    (CaseBlock (Just expr) <$> normalizeExpression var <*>
                     normalizedCases)
              _ ->
                throwNormalizeError
                  "`case` takes an expression followed by `case` clauses."
          "@" ->
            case args of
              [name, pattern'] ->
                EPatternBinding <$>
                (PatternBinding (Just expr) <$> normalizeExpression name <*>
                 normalizeExpression pattern')
              _ -> throwNormalizeError "`@` takes: 1) a name and 2) a pattern."
          "\\" ->
            case args of
              [Parse.SExpression _ (Parse.Symbol _ "list":args'), body] ->
                let normalizedArguments = traverse normalizeExpression args'
                 in ELambda <$>
                    (Lambda (Just expr) <$> normalizedArguments <*>
                     normalizeExpression body)
              _ ->
                throwNormalizeError
                  "`\\` takes exactly two arguments: 1) an argument list and 2) a body."
          "let" ->
            case args of
              [Parse.SExpression _ (Parse.Symbol _ "list":bindings), body] ->
                let normalizedBindings =
                      traverse
                        (\case
                           Parse.SExpression _ [name, value] ->
                             (,) <$> normalizeExpression name <*>
                             normalizeExpression value
                           x ->
                             pushCtxt x $
                             throwNormalizeError
                               "Each `let` binding must be an s-expression containing: 1) a pattern and 2) a value!")
                        bindings
                 in ELetBlock <$>
                    (LetBlock (Just expr) <$> normalizedBindings <*>
                     normalizeExpression body)
              _ ->
                throwNormalizeError
                  "`let` takes exactly two arguments: 1) a bindings list and 2) a body."
          "raw" ->
            case args of
              [rawSource] ->
                let normalizedRawSource =
                      case rawSource of
                        Parse.LiteralString _ x -> pure x
                        x ->
                          pushCtxt x $
                          throwNormalizeError
                            "`raw` takes strings representing the code to inject directly."
                 in ERawExpression (Just expr) . T.pack <$> normalizedRawSource
              _ ->
                throwNormalizeError
                  "`raw` takes exactly one argument: a string literal."
          "record" ->
            let normalizedBindings =
                  traverse
                    (\x ->
                       normalizeExpression x >>= \case
                         EFunctionApplication (FunctionApplication _ (EIdentifier _ field) [val]) ->
                           pure (field, val)
                         _ ->
                           pushCtxt x $
                           throwNormalizeError
                             "Each `record` field setter must be an s-expression containing: 1) a field name and 2) a value!")
                    args
             in ERecordDefinition <$>
                (RecordDefinition (Just expr) <$> normalizedBindings)
          "recordType" ->
            let normalizedFields =
                  traverse
                    (\x ->
                       normalizeExpression x >>= \case
                         EFunctionApplication (FunctionApplication _ (EIdentifier _ field) [ty]) ->
                           pure (field, ty)
                         _ ->
                           pushCtxt x $
                           throwNormalizeError
                             "Each `recordType` field descriptor must be an s-expression containing: 1) a field name and 2) a type!")
                    args
             in ERecordType <$> (RecordType (Just expr) <$> normalizedFields)
          _ ->
            EFunctionApplication <$>
            (FunctionApplication (Just expr) <$>
             normalizeExpression (Parse.Symbol sourceMetadata special) <*>
             traverse normalizeExpression args)
      fn:args ->
        EFunctionApplication <$>
        (FunctionApplication (Just expr) <$> normalizeExpression fn <*>
         traverse normalizeExpression args)
      [] -> pure $ EEmptySExpression (Just expr)
  normalizeExpression expr@(Parse.Symbol _ symbol) =
    pure $ EIdentifier (Just expr) (T.pack symbol)
  
  normalizeFunctionDefinition ::
       ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs)
    => SM.Expression
    -> Identifier
    -> [SM.Expression]
    -> SM.Expression
    -> [SM.Expression]
    -> Eff.Eff effs (FunctionDefinition (Maybe SM.Expression))
  normalizeFunctionDefinition expr fnName arguments body whereDefs =
    FunctionDefinition (Just expr) fnName <$>
    traverse normalizeExpression arguments <*>
    normalizeExpression body <*>
    traverse
      (\x ->
         normalizeStatement x >>= \case
           stmt@(SFunctionDefinition _) -> pure stmt
           stmt@(STypeSignature _) -> pure stmt
           _ ->
             pushCtxt x $
             throwNormalizeError
               "Each `where` binding must be either a function definition or a type signature!")
      whereDefs
  
  normalizeStatement ::
       ('[ Eff.Error Error, Eff.Reader FilePath, Eff.Reader ExprCtxt] :>> effs)
    => SM.Expression
    -> Eff.Eff effs SMStatement
  normalizeStatement expr@(Parse.SExpression _ items) =
    pushCtxt expr $
    case items of
      Parse.Symbol _ special:args ->
        case unhygenisizeIdentifier special of
          "::" ->
            case args of
              [Parse.Symbol _ fnName, Parse.SExpression _ (Parse.Symbol _ "list":constraints), typeDef] ->
                STypeSignature <$>
                (TypeSignature (Just expr) (T.pack fnName) <$>
                 traverse normalizeExpression constraints <*>
                 normalizeExpression typeDef)
              _ ->
                throwNormalizeError
                  "`::` takes three arguments: 1) a function name, 2) a list of constraints, and 3) a type."
          "=" ->
            case args of
              fnSpecifier:body:whereDefs -> do
                (fnName, arguments) <-
                  case fnSpecifier of
                    Parse.Symbol _ fnName -> pure (fnName, [])
                    Parse.SExpression _ (Parse.Symbol _ fnName:args') ->
                      pure (fnName, args')
                    _ ->
                      throwNormalizeError
                        "A function head specifier takes 1) a function name, followed by argument patterns."
                SFunctionDefinition <$>
                  normalizeFunctionDefinition
                    expr
                    (T.pack fnName)
                    arguments
                    body
                    whereDefs
              _ ->
                throwNormalizeError
                  "`=` takes 1) a function head specifier 2) and an expression, followed by `where` bindings."
          "begin" ->
            let normalizedStmts = traverse normalizeStatement args
             in STopLevel . TopLevel (Just expr) <$> normalizedStmts
          "class" ->
            case args of
              Parse.SExpression _ (Parse.Symbol _ "list":classConstraints):className:sigs ->
                let normalizedSigs =
                      traverse
                        (\x ->
                           normalizeStatement x >>= \case
                             STypeSignature tySig -> pure tySig
                             _ ->
                               pushCtxt x $
                               throwNormalizeError
                                 "`class`'s body must contain type signatures!")
                        sigs
                 in STypeclassDefinition <$>
                    (TypeclassDefinition (Just expr) <$>
                     normalizeExpression className <*>
                     traverse normalizeExpression classConstraints <*>
                     normalizedSigs)
              _ ->
                throwNormalizeError
                  "`class` takes a constraint list, a type constructor, and type signatures!"
          "data" ->
            case args of
              typeDef:rest ->
                let (constructors, derivedConstraints) =
                      case last rest of
                        Parse.SExpression _ (Parse.Symbol _ "list":xs) ->
                          (init rest, xs)
                        _ -> (rest, [])
                 in SDataDeclaration <$>
                    (DataDeclaration (Just expr) <$>
                     (normalizeExpression typeDef >>= \case
                        EFunctionApplication typeConstructor ->
                          pure $ TypeConstructor (Just expr) typeConstructor
                        EIdentifier _ properType ->
                          pure $ ProperType (Just expr) properType
                        _ ->
                          pushCtxt typeDef $
                          throwNormalizeError "Invalid type constructor!") <*>
                     traverse normalizeExpression constructors <*>
                     traverse normalizeExpression derivedConstraints)
              _ ->
                throwNormalizeError
                  "`data` takes a type constructor followed by type constructors, optionally followed by a list of constraints to derive!"
          "newtype" ->
            case args of
              typeDef:wrappedType:rest ->
                let derivedConstraints =
                      case rest of
                        [] -> pure []
                        [Parse.SExpression _ (Parse.Symbol _ "list":xs)] ->
                          traverse normalizeExpression xs
                        _ ->
                          throwNormalizeError
                            "Invalid list of constraints to derive!"
                 in SNewtypeDeclaration <$>
                    (NewtypeDeclaration (Just expr) <$>
                     (normalizeExpression typeDef >>= \case
                        EFunctionApplication typeConstructor ->
                          pure $ TypeConstructor (Just expr) typeConstructor
                        EIdentifier _ properType ->
                          pure $ ProperType (Just expr) properType
                        _ ->
                          pushCtxt typeDef $
                          throwNormalizeError "Invalid type constructor!") <*>
                     normalizeExpression wrappedType <*>
                     derivedConstraints)
              _ ->
                throwNormalizeError
                  "`newtype` takes two or three arguments: 1) a type constructor, 2) a type, and optionally 3) a list of constraints to derive!"
          "import" ->
            case args of
              [Parse.Symbol _ moduleName, importSpec] ->
                SRestrictedImport <$>
                (RestrictedImport (Just expr) (T.pack moduleName) <$>
                 normalizeImportSpec importSpec)
              _ ->
                throwNormalizeError
                  "`import` takes exactly two arguments: 1) a module name and 2) an import specification."
          "importm" ->
            case args of
              [Parse.Symbol _ moduleName, macroImportSpec] ->
                SMacroImport . MacroImport (Just expr) (T.pack moduleName) <$>
                normalizeMacroImportSpec macroImportSpec
              _ ->
                throwNormalizeError
                  "`importm` takes exactly two arguments: 1) a module name and 2) a list of macro names."
          "importq" ->
            case args of
              [Parse.Symbol _ moduleName, Parse.Symbol _ alias, importSpec] ->
                SQualifiedImport <$>
                (QualifiedImport (Just expr) (T.pack moduleName) (T.pack alias) <$>
                 normalizeImportSpec importSpec)
              _ ->
                throwNormalizeError
                  "`importq` takes exactly three arguments: 1) a module name, 2) a module name, and 3) an import specification."
          "instance" ->
            case args of
              Parse.SExpression _ (Parse.Symbol _ "list":instanceConstraints):instanceName:defs ->
                let normalizedDefs =
                      traverse
                        (\x ->
                           normalizeStatement x >>= \case
                             SFunctionDefinition fnDef -> pure fnDef
                             _ ->
                               pushCtxt x $
                               throwNormalizeError
                                 "`instance`'s body must only contain function definitions!")
                        defs
                 in STypeclassInstance <$>
                    (TypeclassInstance (Just expr) <$>
                     normalizeExpression instanceName <*>
                     traverse normalizeExpression instanceConstraints <*>
                     normalizedDefs)
              _ ->
                throwNormalizeError
                  "`instance` takes a constraint list, an expression, and a list of function definitions!"
          "pragma" ->
            case args of
              [Parse.LiteralString _ pragma] ->
                pure $ SPragma (Pragma (Just expr) (T.pack pragma))
              _ ->
                throwNormalizeError
                  "`pragma` takes exactly one argument: a string literal."
          "=macro" ->
            case args of
              Parse.Symbol _ macroName:argument:body:whereBindings ->
                SMacroDefinition . MacroDefinition (Just expr) <$>
                normalizeFunctionDefinition
                  expr
                  (T.pack macroName)
                  [argument]
                  body
                  whereBindings
              _ ->
                throwNormalizeError
                  "`=macro` takes 1) an identifier, 2) an argument list, 3) an expression, and 4) a list of statements."
          "module" ->
            case args of
              [Parse.Symbol _ moduleName] ->
                pure $ SModuleDeclaration (Just expr) (T.pack moduleName)
              _ ->
                throwNormalizeError
                  "`module` takes exactly one argument: a module name."
          "raw" ->
            case args of
              [rawSource] ->
                let normalizedRawSource =
                      case rawSource of
                        Parse.LiteralString _ x -> pure $ T.pack x
                        x ->
                          pushCtxt x $
                          throwNormalizeError
                            "`raw` takes strings representing the code to inject directly."
                 in SRawStatement (Just expr) <$> normalizedRawSource
              _ ->
                throwNormalizeError
                  "`raw` takes exactly one argument: a string literal."
          "type" ->
            case args of
              [alias, def] ->
                let normalizedAlias = normalizeExpression alias
                    normalizedDef = normalizeExpression def
                 in STypeSynonym <$>
                    (TypeSynonym (Just expr) <$> normalizedAlias <*> normalizedDef)
              _ ->
                throwNormalizeError
                  "`type` takes exactly two arguments: 1) a type constructor and 2) a type."
          _ -> throwNormalizeError "Invalid statement!"
      _ -> throwNormalizeError "Invalid statement!"
    where
      normalizeMacroImportSpec importSpec =
        case importSpec of
          Parse.SExpression _ (Parse.Symbol _ "list":macroImportList) ->
            traverse
              (\case
                 Parse.Symbol _ import' -> pure $ T.pack import'
                 x ->
                   pushCtxt x $
                   throwNormalizeError "A macro import must be an identifier!")
              macroImportList
          x ->
            pushCtxt x $
            throwNormalizeError
              "`importm`'s import specification must be a list of identifiers (`all` is not valid for macro imports)!"
      normalizeImportSpec importSpec =
        case importSpec of
          Parse.Symbol _ "all" -> pure $ ImportAll (Just expr)
          Parse.SExpression _ (Parse.Symbol _ "list":importList) ->
            normalizeImportList importList
          x ->
            pushCtxt x $
            throwNormalizeError
              "An import specification must be either `all` or a list of import items!"
      normalizeImportList input =
        ImportOnly (Just expr) <$>
        traverse
          (\item ->
             pushCtxt item $
             case item of
               Parse.Symbol _ import' ->
                 pure $ ImportItem (Just expr) (T.pack import')
               Parse.SExpression _ (Parse.Symbol _ type':imports) ->
                 let normalizedImports =
                       traverse
                         (\case
                            Parse.Symbol _ import' -> pure $ T.pack import'
                            x ->
                              pushCtxt x $
                              throwNormalizeError
                                "An import subitem must be an identifier!")
                         imports
                  in ImportType (Just expr) (T.pack type') <$> normalizedImports
               _ ->
                 throwNormalizeError
                   "An import item must be either an identifier or an s-expression of identifiers!")
          input
  normalizeStatement expr =
    pushCtxt expr $ throwNormalizeError "Invalid top-level form!"
  
  unsafeNormalize ::
       (SM.Expression -> Eff.Eff '[ Eff.Reader ExprCtxt, Eff.Reader FilePath, Eff.Error Error] a)
    -> SM.Expression
    -> a
  unsafeNormalize f =
    Eff.runPureEff .
    unsafeRunError renderError . Eff.runReader (FilePath "") . withExprCtxt . f
  