content: {-# OPTIONS_HADDOCK hide #-}
  
  module DDC.Core.Codec.Text.Parser.Module
          (pModule)
  where
  import DDC.Core.Codec.Text.Parser.Type
  import DDC.Core.Codec.Text.Parser.Exp
  import DDC.Core.Codec.Text.Parser.Context
  import DDC.Core.Codec.Text.Parser.Base
  import DDC.Core.Codec.Text.Parser.ExportSpec
  import DDC.Core.Codec.Text.Parser.ImportSpec
  import DDC.Core.Codec.Text.Parser.DataDef
  import DDC.Core.Codec.Text.Lexer.Tokens
  
  import DDC.Core.Module
  import DDC.Core.Exp.Annot
  import DDC.Data.Pretty
  import Data.Char
  import qualified Data.Map               as Map
  import qualified Data.Set               as Set
  import qualified Data.Text              as T
  import qualified DDC.Control.Parser     as P
  
  
  -- | Parse a core module.
  pModule :: (Ord n, Pretty n)
          => Context n
          -> Parser n (Module P.SourcePos n)
  pModule c
   = do   sp      <- pTokSP (KKeyword EModule)
          modName <- pModuleName
  
          -- Parse header declarations
          heads                   <- P.many (pHeadDecl c modName)
          let importSpecs_noArity = concat $ [specs  | HeadImportSpecs   specs <- heads ]
          let exportSpecs         = concat $ [specs  | HeadExportSpecs   specs <- heads ]
  
          let dataDefsLocal       = [(n, def)     | HeadDataDef     n def     <- heads ]
          let typeDefsLocal       = [(n, (k, t))  | HeadTypeDef     n k t     <- heads ]
  
          -- Attach arity information to import specs.
          --   The aritity information itself comes in the ARITY pragmas,
          --   which are parsed as separate top level things.
          let importArities
                  = Map.fromList  [ (n, (iTypes, iValues, iBoxes ))
                                  | HeadPragmaArity n iTypes iValues iBoxes <- heads ]
  
          let attachAritySpec (ImportForeignValue n (ImportValueModule mn v t _))
                  = ImportForeignValue n (ImportValueModule mn v t (Map.lookup n importArities))
  
              attachAritySpec spec = spec
  
          let importSpecs
                  = map attachAritySpec importSpecs_noArity
  
  
          -- Parse function definitions.
          --  If there is a 'with' keyword then this is a standard module with bindings.
          --  If not, then it is a module header, which doesn't need bindings.
          (lts, isHeader)
           <- P.choice
                  [ do    pTok (KKeyword EWith)
  
                          -- LET;+
                          lts  <- P.sepBy1 (pLetsSP c) (pTok (KKeyword EIn))
                          let lts' = concat [map (\l -> (l, sp')) ls  | (ls, sp') <- lts]
  
                          return (lts', False)
  
                  , do    return ([],  True) ]
  
          -- The body of the module consists of the top-level bindings wrapped
          -- around a unit constructor place-holder.
          let body = xLetsAnnot lts (xUnit sp)
  
          return  $ ModuleCore
                  { moduleName            = modName
                  , moduleIsHeader        = isHeader
                  , moduleTransitiveDeps  = Set.empty
                  , moduleExportTypes     = []
                  , moduleExportValues    = [(n, s)       | ExportValue n s        <- exportSpecs]
                  , moduleImportModules   = [mn           | ImportModule mn        <- importSpecs]
                  , moduleImportTypes     = [(n, s)       | ImportForeignType  n s <- importSpecs]
                  , moduleImportCaps      = [(n, s)       | ImportForeignCap   n s <- importSpecs]
                  , moduleImportValues    = [(n, s)       | ImportForeignValue n s <- importSpecs]
                  , moduleImportTypeDefs  = [(n, (k, t))  | ImportType  n k t      <- importSpecs]
  
                  , moduleImportDataDefs  = [(dataDefTypeName def, def)
                                                          | ImportData  def       <- importSpecs]
  
                  , moduleLocalDataDefs   = dataDefsLocal
                  , moduleLocalTypeDefs   = typeDefsLocal
  
                  , moduleBody            = body }
  
  
  ---------------------------------------------------------------------------------------------------
  -- | Wrapper for a declaration that can appear in the module header.
  data HeadDecl n
          -- | Import specifications.
          = HeadImportSpecs  [ImportSpec  n]
  
          -- | Export specifications.
          | HeadExportSpecs  [ExportSpec  n]
  
          -- | Data type definitions.
          | HeadDataDef      n  (DataDef     n)
  
          -- | Type equations.
          | HeadTypeDef      n (Kind n) (Type n)
  
          -- | Arity pragmas.
          --   Number of type parameters, value parameters, and boxes for some super.
          | HeadPragmaArity  n Int Int Int
  
  
  -- | Parse one of the declarations that can appear in a module header.
  pHeadDecl :: (Ord n, Pretty n)
            => Context n -> ModuleName -> Parser n (HeadDecl n)
  
  pHeadDecl ctx modName
   = P.choice
          [ do    imports <- pImportSpecs ctx modName
                  return  $ HeadImportSpecs imports
  
          , do    exports <- pExportSpecs ctx modName
                  return  $ HeadExportSpecs exports
  
          , do    def     <- pDataDef ctx (Just modName)
                  return  $ HeadDataDef (dataDefTypeName def) def
  
          , do    (n, k, t) <- pTypeDef ctx
                  return  $ HeadTypeDef n k t
  
          , do    pHeadPragma ctx
          ]
  
  
  -- | Parse a type equation.
  pTypeDef :: (Ord n, Pretty n)
           => Context n -> Parser n (n, Kind n, Type n)
  pTypeDef c
   = do   pKey    EType
          n       <- pName
          pTokSP  (KOp ":")
          k       <- pType c
          pSym SEquals
          t       <- pType c
          pSym SSemiColon
          return  (n, k, t)
  
  
  -- | Parse one of the pragmas that can appear in the module header.
  pHeadPragma :: Context n -> Parser n (HeadDecl n)
  pHeadPragma ctx
   = do   (txt, sp)      <- pPragmaSP
          case words $ T.unpack txt of
  
           -- The type and value arity of a super.
           ["ARITY", name, strTypes, strValues, strBoxes]
            |  all isDigit strTypes
            ,  all isDigit strValues
            ,  all isDigit strBoxes
            ,  Just makeLitName <- contextMakeLiteralName ctx
            ,  Just n           <- makeLitName sp (LString (T.pack name)) True
            -> return $ HeadPragmaArity n
                  (read strTypes) (read strValues) (read strBoxes)
  
           _ -> P.unexpected $ "pragma " ++ "{-# " ++ T.unpack txt ++ "#-}"
  