content: -- #hide
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Language.Haskell.ParseUtils
  -- Copyright   :  (c) The GHC Team, 1997-2000
  -- License     :  BSD-style (see the file libraries/base/LICENSE)
  --
  -- Maintainer  :  libraries@haskell.org
  -- Stability   :  experimental
  -- Portability :  portable
  --
  -- Utilities for the Haskell parser.
  --
  -----------------------------------------------------------------------------
  
  module FrontEnd.ParseUtils (
  	  splitTyConApp		-- HsType -> P (Name,[HsType])
  	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp
  	, checkPrec		-- Integer -> P Int
  	, checkContext		-- HsType -> P HsContext
  	, checkDataHeader	-- HsQualType -> P (HsContext,Name,[Name])
  	, checkPattern		-- HsExp -> P HsPat
  	, checkPatterns
  	, checkExpr		-- HsExp -> P HsExp
  	, checkValDef		-- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
  	, checkUnQual		-- Name -> P Name
          , readInteger
          , readRational
          , fixupHsDecls
          , parseError
          , parseExport
          , qualTypeToClassHead
          , doForeign
          , doForeignEq
   ) where
  
  import Data.Char
  import Data.Maybe
  import Data.Monoid
  import Data.Ratio
  import qualified Data.Set as Set
  import qualified Data.Traversable as T
  
  import C.FFI
  import FrontEnd.HsSyn
  import FrontEnd.ParseMonad
  import FrontEnd.SrcLoc
  import Name.Name
  import Name.Names
  import PackedString
  
  parseError :: String -> P a
  parseError = fail
  
  splitTyConApp :: HsType -> P (Name,[HsType])
  splitTyConApp t0 = split t0 []
   where
  	split :: HsType -> [HsType] -> P (Name,[HsType])
  	split (HsTyApp t u) ts = split t (u:ts)
  	split (HsTyCon t) ts = return (t,ts)
  	split _ _ = fail "Illegal data/newtype declaration"
  --	split a b = fail $ "Illegal data/newtype declaration: " ++ show (a,b)
  
  -----------------------------------------------------------------------------
  -- Various Syntactic Checks
  
  qualTypeToClassHead :: HsQualType -> P HsClassHead
  qualTypeToClassHead qt = do
      let fromHsTypeApp t = f t [] where
              f (HsTyApp a b) rs = f a (b:rs)
              f t rs = (t,rs)
      case fromHsTypeApp $ hsQualTypeType qt of
          (HsTyCon className,as) -> return HsClassHead { hsClassHeadContext = hsQualTypeContext qt, hsClassHead = className, hsClassHeadArgs = as }
          _ -> fail "Invalid Class Head"
  
  checkContext :: HsType -> P HsContext
  checkContext (HsTyCon (toName TypeConstructor -> name)) | name == tc_Unit = return []
  checkContext (HsTyTuple ts) =
  	mapM checkAssertion ts
  checkContext t = do
  	c <- checkAssertion t
  	return [c]
  
  -- Changed for multi-parameter type classes
  
  checkAssertion :: HsType -> P HsAsst
  checkAssertion t =  checkAssertion' [] t
  	where	checkAssertion' ts (HsTyCon c) =  tast (c,ts)
  		checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a
  		checkAssertion' _ _ = fail "Illegal class assertion"
                  tast (a,[HsTyVar n]) = return (HsAsst a [n]) -- (a,n)
                  tast _ = fail "Invalid Class. multiparameter classes not yet supported"
  --checkAssertion = checkAssertion' []
  --	where	checkAssertion' ts (HsTyCon c) = return (c,ts)
  --		checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a
  --		checkAssertion' _ _ = fail "Illegal class assertion"
  
  checkPatterns :: [HsExp] -> P [HsPat]
  checkPatterns es = mapM checkPattern es
  
  checkDataHeader :: HsQualType -> P (HsContext,Name,[Name])
  checkDataHeader (HsQualType cs t) = do
  	(c,ts) <- checkSimple "data/newtype" t []
  	return (cs,c,ts)
  
  checkSimple :: String -> HsType -> [Name] -> P ((Name,[Name]))
  checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)
  checkSimple _kw (HsTyCon t)   xs = return (t,xs)
  checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration")
  --checkSimple kw t ts = fail ("Illegal " ++ kw ++ " declaration: " ++ show (t,ts))
  
  {-
  checkInstHeader :: HsQualType -> P (HsContext,Name,[HsType])
  checkInstHeader (HsQualType cs t) = do
  	(c,ts) <- checkInsts t []
  	return (cs,c,ts)
  
  checkInsts :: HsType -> [HsType] -> P ((Name,[HsType]))
  checkInsts (HsTyApp l t) ts = checkInsts l (t:ts)
  checkInsts (HsTyCon c)   ts = return (c,ts)
  checkInsts _ _ = fail "Illegal instance declaration"
  -}
  
  -----------------------------------------------------------------------------
  -- Checking Patterns.
  
  -- We parse patterns as expressions and check for valid patterns below,
  -- converting the expression into a pattern at the same time.
  
  checkPattern :: HsExp -> P HsPat
  checkPattern e = checkPat e []
  
  checkPat :: HsExp -> [HsPat] -> P HsPat
  checkPat (HsCon c) args = return (HsPApp c args)
  checkPat (HsApp f x) args = do
  	x <- checkPat x []
  	checkPat f (x:args)
  checkPat e [] = case e of
  	HsVar x   -> return (HsPVar x)
  	HsLit l            -> return (HsPLit l)
  	HsInfixApp l op r  -> do
  			      l <- checkPat l []
  			      r <- checkPat r []
  			      case op of
  				 HsCon c -> return (HsPInfixApp l c r)
  				 _ -> patFail
  	HsTuple es         -> do
  			      ps <- mapM (\e -> checkPat e []) es
  			      return (HsPTuple ps)
  	HsUnboxedTuple es  -> do
  			      ps <- mapM (\e -> checkPat e []) es
  			      return (HsPUnboxedTuple ps)
  	HsList es	   -> do
  			      ps <- mapM (\e -> checkPat e []) es
  			      return (HsPList ps)
  	HsParen e	   -> do
  			      p <- checkPat e []
  			      return (HsPParen p)
  	HsAsPat n e	   -> do
  			      p <- checkPat e []
  			      return (HsPAsPat n p)
  	HsWildCard _	   -> return HsPWildCard
  	HsIrrPat e         -> do
  			      p <- T.mapM checkPattern e
  			      return (HsPIrrPat p)
  	HsBangPat e         -> do
  			      p <- T.mapM checkPattern e
  			      return (HsPBangPat p)
  	HsRecConstr c fs   -> do
  			      fs <- mapM checkPatField fs
  			      return (HsPRec c fs)
  	HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))
          HsExpTypeSig sl e t -> do
              p <- checkPat e []
              return (HsPTypeSig sl p t)
  	_ -> patFail
  
  checkPat _ _ = patFail
  
  checkPatField :: HsFieldUpdate -> P HsPatField
  checkPatField (HsFieldUpdate n e) = do
  	p <- checkPat e []
  	return (HsPFieldPat n p)
  
  patFail :: P a
  patFail = fail "Parse error in pattern"
  
  -----------------------------------------------------------------------------
  -- Check Expression Syntax
  
  checkExpr :: HsExp -> P HsExp
  checkExpr e = case e of
  	HsVar _			  -> return e
  	HsCon _			  -> return e
  	HsLit _			  -> return e
  	HsInfixApp e1 op e2	  -> check2Exprs e1 e2 (flip HsInfixApp op)
  	HsApp e1 e2		  -> check2Exprs e1 e2 HsApp
  	HsNegApp e		  -> check1Expr e HsNegApp
  	HsLambda loc ps e	  -> check1Expr e (HsLambda loc ps)
  	HsLet bs e		  -> check1Expr e (HsLet bs)
  	HsIf e1 e2 e3		  -> check3Exprs e1 e2 e3 HsIf
  	HsCase e alts		  -> do
  				     alts <- mapM checkAlt alts
  				     e <- checkExpr e
  				     return (HsCase e alts)
  	HsDo stmts		  -> do
  				     stmts <- mapM checkStmt stmts
  				     return (HsDo stmts)
  	HsTuple es		  -> checkManyExprs es HsTuple
  	HsUnboxedTuple es	  -> checkManyExprs es HsUnboxedTuple
  	HsList es		  -> checkManyExprs es HsList
  	HsParen e		  -> check1Expr e HsParen
  	HsLeftSection e op	  -> check1Expr e (flip HsLeftSection op)
  	HsRightSection op e	  -> check1Expr e (HsRightSection op)
  	HsRecConstr c fields	  -> do
  				     fields <- mapM checkField fields
  				     return (HsRecConstr c fields)
  	HsRecUpdate e fields	  -> do
  				     fields <- mapM checkField fields
  				     e <- checkExpr e
  				     return (HsRecUpdate e fields)
  	HsEnumFrom e		  -> check1Expr e HsEnumFrom
  	HsEnumFromTo e1 e2	  -> check2Exprs e1 e2 HsEnumFromTo
  	HsEnumFromThen e1 e2      -> check2Exprs e1 e2 HsEnumFromThen
  	HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo
  	HsListComp e stmts        -> do
  				     stmts <- mapM checkStmt stmts
  				     e <- checkExpr e
  				     return (HsListComp e stmts)
  	HsExpTypeSig loc e ty     -> do
  				     e <- checkExpr e
  				     return (HsExpTypeSig loc e ty)
          HsAsPat _ _     -> fail "@ only valid in pattern"
          HsWildCard sl   -> return $ HsWildCard sl -- TODO check for strict mode
          HsIrrPat _      -> fail "~ only valid in pattern"
  	_                         -> fail "Parse error in expression"
  
  -- type signature for polymorphic recursion!!
  check1Expr :: HsExp -> (HsExp -> a) -> P a
  check1Expr e1 f = do
  	e1 <- checkExpr e1
  	return (f e1)
  
  check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a
  check2Exprs e1 e2 f = do
  	e1 <- checkExpr e1
  	e2 <- checkExpr e2
  	return (f e1 e2)
  
  check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a
  check3Exprs e1 e2 e3 f = do
  	e1 <- checkExpr e1
  	e2 <- checkExpr e2
  	e3 <- checkExpr e3
  	return (f e1 e2 e3)
  
  checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a
  checkManyExprs es f = do
  	es <- mapM checkExpr es
  	return (f es)
  
  checkAlt :: HsAlt -> P HsAlt
  checkAlt (HsAlt loc p galts bs) = do
  	galts <- checkGAlts galts
  	return (HsAlt loc p galts bs)
  
  checkGAlts :: HsRhs -> P HsRhs
  checkGAlts (HsUnGuardedRhs e) = check1Expr e HsUnGuardedRhs
  checkGAlts (HsGuardedRhss galts) = do
  	galts <- mapM checkGAlt galts
  	return (HsGuardedRhss galts)
  
  checkGAlt :: HsGuardedRhs -> P HsGuardedRhs
  checkGAlt (HsGuardedRhs loc e1 e2) = check2Exprs e1 e2 (HsGuardedRhs loc)
  
  checkStmt :: HsStmt -> P HsStmt
  checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p)
  checkStmt (HsQualifier e) = check1Expr e HsQualifier
  checkStmt s@(HsLetStmt _) = return s
  
  checkField :: HsFieldUpdate -> P HsFieldUpdate
  checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)
  
  -----------------------------------------------------------------------------
  -- Check Equation Syntax
  
  checkValDef :: SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
  checkValDef srcloc lhs rhs whereBinds =
      case isFunLhs lhs [] of
  	 Just (f,es) -> do
  			ps <- mapM checkPattern es
  			return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])
           Nothing     -> do
  			lhs <- checkPattern lhs
  			return (HsPatBind srcloc lhs rhs whereBinds)
  
  -- A variable binding is parsed as an HsPatBind.
  
  isFunLhs :: HsExp -> [HsExp] -> Maybe (Name, [HsExp])
  isFunLhs (HsInfixApp l (HsVar ( op)) r) es = Just (op, l:r:es)
  isFunLhs (HsApp (HsVar ( f)) e) es = Just (f, e:es)
  isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)
  isFunLhs (HsApp f e) es = isFunLhs f (e:es)
  isFunLhs _ _ = Nothing
  
  -----------------------------------------------------------------------------
  -- In a class or instance body, a pattern binding must be of a variable.
  
  {-
  checkClassBody :: [HsDecl] -> P [HsDecl]
  checkClassBody decls = do
  	mapM_ checkMethodDef decls
  	return decls
  
  checkMethodDef :: HsDecl -> P ()
  checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return ()
  checkMethodDef (HsPatBind loc _ _ _) =
  	fail "illegal method definition" `atSrcLoc` loc
  checkMethodDef _ = return ()
  -}
  
  -----------------------------------------------------------------------------
  -- Check that an identifier or symbol is unqualified.
  -- For occasions when doing this in the grammar would cause conflicts.
  
  checkUnQual :: Name -> P Name
  checkUnQual n = if isJust (getModule n) then fail "Illegal qualified name" else return n
  --checkUnQual (Qual _ _) = fail "Illegal qualified name"
  --checkUnQual n@(UnQual _) = return n
  --checkUnQual (Special _) = fail "Illegal special name"
  
  -----------------------------------------------------------------------------
  -- Miscellaneous utilities
  
  checkPrec :: Integer -> P Int
  checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)
  checkPrec i | otherwise	       = fail ("Illegal precedence " ++ show i)
  
  mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp
  mkRecConstrOrUpdate (HsCon c) fs       = return (HsRecConstr c fs)
  mkRecConstrOrUpdate e         fs@(_:_) = return (HsRecUpdate e fs)
  mkRecConstrOrUpdate _         _        = fail "Empty record update"
  
  -----------------------------------------------------------------------------
  -- Reverse a list of declarations, merging adjacent HsFunBinds of the
  -- same name and checking that their arities match.
  
  {-
  checkRevDecls :: [HsDecl] -> P [HsDecl]
  checkRevDecls = mergeFunBinds []
      where
  	mergeFunBinds revDs [] = return revDs
  	mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) =
  		mergeMatches ms1 ds1
  	    where
  		arity = length ps
  		mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds)
  		    | name' == name =
  			if length ps' /= arity
  			then fail ("arity mismatch for '" ++ show name ++ "'")
  			     `atSrcLoc` loc
  			else mergeMatches (ms++ms') ds
  		mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds
  	mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds
  -}
  
  -- this used to be done in post-process
  
  -- collect associated funbind equations (matches) into a single funbind
  -- intended as a post-processer for the parser output
  fixupHsDecls :: [HsDecl] -> [HsDecl]
  fixupHsDecls (d@(HsFunBind matches):ds) =  (HsFunBind newMatches) : fixupHsDecls different where
      funName = matchName $ head matches
      (same, different) = span (sameFun funName) (d:ds)
      newMatches =  collectMatches same
  fixupHsDecls (d:ds) =  d : fixupHsDecls ds
  fixupHsDecls [] = []
  -- get the variable name bound by a match
  matchName (HsMatch _sloc name _pats _rhs _whereDecls) = name
  
  -- True if the decl is a HsFunBind and binds the same name as the
  -- first argument, False otherwise
  sameFun :: Name -> HsDecl -> Bool
  sameFun name (HsFunBind matches@(_:_)) = name == (matchName $ head matches)
  sameFun _ _ = False
  
  doForeign :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> m HsDecl
  doForeign srcLoc names ms qt = ans where
      ans = do
          (mstring,vname@(nameParts -> (_,Nothing,cname)),names') <- case ms of
              Just (s,n) -> return (Just s,n,names)
              Nothing -> do
                  (n:ns) <- return $ reverse names
                  return (Nothing,n,reverse ns)
          let f ["import","primitive"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe Primitive) vname qt
              f ["import","dotnet"] cname = return $ HsForeignDecl srcLoc (FfiSpec (Import cname mempty) Safe DotNet) vname qt
              f ("import":rs) cname = do
                  let (safe,conv) = pconv rs
                  im <- parseImport conv mstring vname
                  conv <- return (if conv == CApi then CCall else conv)
                  return $ HsForeignDecl srcLoc (FfiSpec im safe conv) vname qt
              f ("export":rs) cname = do
                  let (safe,conv) = pconv rs
                  return $ HsForeignExport srcLoc (FfiExport cname safe conv undefined undefined) vname qt
              f _ _ = error "ParseUtils: bad."
          f (map show names') (maybe cname id mstring) where
      pconv rs = g Safe CCall rs where
          g _ cc ("safe":rs) = g Safe cc rs
          g _ cc ("unsafe":rs) = g Unsafe cc rs
          g _ cc ("jhc_context":rs) = g JhcContext cc rs
          g s _  ("ccall":rs)  = g s CCall rs
          g s _  ("capi":rs)  = g s CApi rs
          g s _  ("stdcall":rs) = g s StdCall rs
          g s c  [] = (s,c)
          g _ _ rs = error $ "FrontEnd.ParseUtils: unknown foreign flags " ++ show rs
  
  doForeignEq :: Monad m => SrcLoc -> [Name] -> Maybe (String,Name) -> HsQualType -> HsExp -> m HsDecl
  doForeignEq srcLoc names ms qt e = undefined
  
  -- FFI parsing
  
  parseExport :: Monad m => String -> Name -> m String
  parseExport cn hn =
      case words cn of
        [x] | isCName x -> return x
        []              -> return (show hn)
        _               -> fail ("Invalid cname in export declaration: "++show cn)
  
  parseImport :: Monad m => CallConv -> Maybe String -> Name -> m FfiType
  parseImport _ Nothing hn = return $ Import (show hn) mempty
  parseImport cc (Just cn) hn =
      case words cn of
        ["dynamic"]   -> return Dynamic
        ["wrapper"]   -> return Wrapper
        []            -> return $ Import (show hn) mempty
        ("static":xs) -> parseIS cc xs
        xs            -> parseIS cc xs
  
  parseIS cc rs = f Set.empty rs where
      f s ['&':n] | isCName n = return $ ImportAddr n $ Requires s
      f s [n]     | isCName n = return $ Import     n $ Requires s
      f s ["&",n] | isCName n = return $ ImportAddr n $ Requires s
      f s (i:r)               = f (Set.insert (cc,packString i) s) r
      f s x                   = fail ("Syntax error parsing foreign import: "++show x)
  
  isCName []     = False
  isCName (c:cs) = p1 c && all p2 cs
      where p1 c = isAlpha c    || any (c==) oa
            p2 c = isAlphaNum c || any (c==) oa
            oa   = "_-$"
  
  -- collects all the HsMatch equations from any FunBinds
  -- from a list of HsDecls
  collectMatches :: [HsDecl] -> [HsMatch]
  collectMatches [] = []
  collectMatches (d:ds)
     = case d of
          (HsFunBind matches) -> matches ++ collectMatches ds
          _anythingElse             -> collectMatches ds
  
  -- Stolen from Hugs' Prelude
  
  readInteger :: String -> Integer
  readInteger ('0':'o':ds) = readInteger2  8 isOctDigit ds
  readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds
  readInteger          ds  = readInteger2 10 isDigit    ds
  
  readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer
  readInteger2 radix _ ds = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) ds)
  
  -- Hack...
  
  readRational :: String -> Rational
  readRational xs = (readInteger (i++m))%1 * 10^^(case e of {[] -> 0;  ('+':e2) -> read e2; _ -> read e} - length m)
    where (i,r1) = span isDigit xs
          (m,r2) = span isDigit (dropWhile (=='.') r1)
          e      = dropWhile (=='e') r2
  