content: {-# OPTIONS_HADDOCK hide #-}
  
  module DDC.Source.Discus.Parser.Param
          ( -- * Parameters
            pTypeParams
          , pTermParams
          , pDeclTermParamsSP
          , funTypeOfParams
  
            -- * Patterns
          , pPat
          , pPatSimple)
  where
  import DDC.Source.Discus.Parser.Type
  import DDC.Source.Discus.Parser.Base
  import DDC.Source.Discus.Exp                    as S
  import DDC.Core.Codec.Text.Lexer.Tokens
  import qualified DDC.Core.Exp                   as C
  import qualified DDC.Control.Parser             as P
  import qualified Data.Text                      as Text
  import Data.Maybe
  
  
  -- Params ---------------------------------------------------------------------
  -- | Parse some type parameters.
  pTypeParams :: Parser [(Bind, Maybe Type)]
  pTypeParams
   = P.choice
   [ fmap concat
      $ P.many $ do
          pSym SRoundBra
          bs'     <- P.many1 pBind
          pTok (KOp ":")
          t       <- pType
          pSym SRoundKet
          return  [(b, Just t)  | b <- bs']
  
   , do   bs'     <- P.many1 pBind
          return  [(b, Nothing) | b <- bs']
   ]
  
  
  -- | Parse some term parameters.
  pTermParams :: Parser [(ParamSort, Either Bind Pat, Maybe Type)]
  pTermParams
   = P.choice
   [      -- Explicit annotated term parameters.
     P.try $ do
           pSym SRoundBra
           ps   <- P.many1 pPatSimple
           pTok (KOp ":")
           t    <- pType
           pSym SRoundKet
           return  [(MSTerm, Right p, Just t) | p <- ps]
  
   , P.try $ do
           pSym SBraceBra
           P.choice
            [ do  -- Implicit annotated type parameters.
                  pSym SAt
                  bs  <- P.many pBind
                  pTok (KOp ":")
                  t    <- pType
                  pSym SBraceKet
                  return [(MSType, Left b, Just t) | b <- bs ]
  
  
            , do  -- Implicit annoated term parameters.
                  ps   <- P.many1 pPatSimple
                  pTok (KOp ":")
                  t    <- pType
                  pSym SBraceKet
                  return  [(MSImplicit, Right p, Just t) | p <- ps]
            ]
  
           -- Explicit term parameters.
   , do   ps      <- P.many1 pPatSimple
          return  [(MSTerm, Right p, Nothing) | p <- ps]
   ]
  
  
  -- Function parameters.
  pDeclTermParamsSP :: Parser [Param]
  pDeclTermParamsSP
   = P.choice
          -- Type parameter
          --   [BIND1 BIND2 .. BINDN : TYPE]
   [ do   pSym SSquareBra
          bs      <- P.many1 pBind
          pTok (KOp ":")
          t       <- pType
          pSym SSquareKet
          return  [ MType b (Just t) | b <- bs]
  
          -- Type parameter in new syntax.
   , P.try $ do
          pSym  SBraceBra
          pSym SAt
          bs      <- P.many1 pBind
          pTok (KOp ":")
          t       <- pType
          pSym  SBraceKet
          return  [ MType b (Just t) | b <- bs ]
  
          -- Implicit term parameter
          --   {BIND : TYPE}
   , do   pSym  SBraceBra
          ps      <- P.choice
                  [  P.try $ do
                          ps      <- P.many1 pPatSimple
                          pTok (KOp ":")
                          t       <- pType
                          return  [ MImplicit p (Just t) | p <- ps ]
  
                  , do    t       <- pType
                          return  [ MImplicit PDefault (Just t) ]
                  ]
          pSym  SBraceKet
          return  ps
  
  
          -- Value parameter without a type annotation.
          --   This needs to come before the case for value patterns with type
          --   annotations because both records and the unit data constructor
          --   pattern start with a '('.
   , do   p       <- pPatSimple
          return  [MTerm p Nothing]
  
  
          -- Term pattern with type annotations.
          -- (BIND1 BIND2 .. BINDN : TYPE)
   , do   pSym    SRoundBra
          ps      <- P.choice
                  [  P.try $ do
                          ps      <- P.many1 pPatSimple
                          pTok (KOp ":")
                          t       <- pType
                          return  [ MTerm p (Just t) | p <- ps ]
  
                  , do    p       <- pPat
                          return  [ MTerm p Nothing ]
                  ]
  
          pSym    SRoundKet
          return ps
   ]
   <?> "a function parameter"
  
  
  --   and the type of the body.
  funTypeOfParams
          :: [Param]      -- ^ Spec of parameters.
          -> Type         -- ^ Type of body.
          -> Type         -- ^ Type of whole function.
  
  funTypeOfParams [] tBody
   = tBody
  
  funTypeOfParams (p:ps) tBody
   = case p of
          MType     b mt
           -> let k       = fromMaybe (TBot S.KData) mt
              in  TApp (TCon (TyConForall k)) (TAbs b k $ funTypeOfParams ps tBody)
  
          MTerm     _ mt
           -> let k       = fromMaybe (TBot S.KData) mt
              in  TFunExplicit k  $ funTypeOfParams ps tBody
  
          MImplicit  _ mt
           -> let k       = fromMaybe (TBot S.KData) mt
              in  TFunImplicit k  $ funTypeOfParams ps tBody
  
  
  -- Patterns -------------------------------------------------------------------
  -- | Pattern.
  pPat :: Parser Pat
  pPat
   = P.choice
   [  -- Con Bind Bind ...
      do  nCon    <- pDaConBoundName
          ps      <- P.many pPatSimple
          return  $ PData (DaConBound (C.DaConBoundName Nothing Nothing nCon)) ps
  
      -- Base pattern.
   ,  do  p       <- pPatSimple
          return  p
   ]
   <?> "a pattern"
  
  
  -- | Simple pattern.
  pPatSimple :: Parser Pat
  pPatSimple
   = P.choice
   [
          -- Tuple pattern.
     P.try $ do
          _sp       <- pSym SRoundBra
          pField1   <- pPat
          _         <- pSym SComma
          psField'  <- P.sepBy1 pPat (pSym SComma)
          _         <- pSym SRoundKet
          let ps    =  pField1 : psField'
          let arity =  length ps
          let nCtor =  Text.pack ("T" ++ show arity)
          return    $  PData (DaConBound (C.DaConBoundName Nothing Nothing (DaConBoundName nCtor))) ps
  
          -- Sugared record pattern.
          -- like (x = a, y = b, z = c)
   , P.try $ do
          _       <- pSym SRoundBra
  
          (nsField, psField)
           <- fmap unzip
            $ P.sepBy
                  (do (n, _)  <- pVarNameSP
                      _       <- pSym SEquals
                      p       <- pPatSimple
                      return (n, p))
                  (pSym SComma)
  
          pSym SRoundKet
          return  $ PData (DaConRecord nsField) psField
  
          -- Primitive record pattern.
          -- like (x,y,z)# a b c
    , P.try $ do
          _       <- pSym SRoundBra
          nsField <- fmap (map fst) $ P.sepBy pVarNameSP (pSym SComma)
          pSym SRoundKet
          pSym SHash
          psField <- P.many pPatSimple
          return  $ PData (DaConRecord nsField) psField
  
          -- ( PAT )
   , P.try $ do
          pSym SRoundBra
          p       <- pPat
          pSym SRoundKet
          return  $ p
  
          -- Wildcard
          --   Try this case before the following one for binders
          --   so that '_' is parsed as the default pattern,
          --   rather than a wildcard binder.
   , do   pSym SUnderscore
          return  $ PDefault
  
          -- Var
   , do   b       <- pBind
          P.choice
           [ do   _       <- pSym SAt
                  p       <- pPatSimple
                  return  $  PAt b p
  
           , do   return  $  PVar b
           ]
  
          -- Lit
   , do   nLit    <- pDaConBoundLit
          return  $ PData (DaConPrim nLit) []
  
          -- Named algebraic constructors.
   , do   nCon    <- pDaConBoundName
          return  $ PData (DaConBound (C.DaConBoundName Nothing Nothing nCon)) []
  
          -- 'Unit'
   , do   pTok    (KBuiltin BDaConUnit)
          return  $ PData  dcUnit []
   ]
   <?> "a pattern"
  
  
  