<commit_before>%
% (c) The GRASP/AQUA Project, Glasgow University, 1999
%
\section[ParseUtil]{Parser Utilities}

\begin{code}
module ParseUtil (
	  parseError		-- String -> Pa
	, cbot			-- a
	, mkVanillaCon, mkRecCon,

	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp
	, groupBindings
	
	, mkExtName             -- RdrName -> ExtName

	, checkPrec 		-- String -> P String
	, checkContext		-- HsType -> P HsContext
	, checkInstType		-- HsType -> P HsType
	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
	, checkPattern		-- HsExp -> P HsPat
	, checkPatterns		-- SrcLoc -> [HsExp] -> P [HsPat]
	, checkDo		-- [HsStmt] -> P [HsStmt]
	, checkValDef		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
	, checkValSig		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 ) where

#include "HsVersions.h"

import Lex
import HsSyn		-- Lots of it
import SrcLoc
import RdrHsSyn		( RdrBinding(..),
			  RdrNameHsType, RdrNameBangType, RdrNameContext,
			  RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
			  RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
			)
import RdrName
import PrelNames	( unitTyCon_RDR )
import OccName  	( dataName, varName, tcClsName,
			  occNameSpace, setOccNameSpace, occNameUserString )
import CStrings		( CLabelString )
import FastString	( unpackFS )
import Outputable

-----------------------------------------------------------------------------
-- Misc utils

parseError :: String -> P a
parseError s = 
  getSrcLocP `thenP` \ loc ->
  failMsgP (hcat [ppr loc, text ": ", text s])

cbot = panic "CCall:result_ty"

-----------------------------------------------------------------------------
-- mkVanillaCon

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)

mkVanillaCon ty tys
 = split ty tys
 where
   split (HsAppTy t u)  ts = split t (unbangedType u : ts)
   split (HsTyVar tc)   ts = tyConToDataCon tc	`thenP` \ data_con ->
			     returnP (data_con, VanillaCon ts)
   split _		 _ = parseError "Illegal data/newtype declaration"

mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
mkRecCon con fields
  = tyConToDataCon con	`thenP` \ data_con ->
    returnP (data_con, RecCon fields)

tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
  | occNameSpace tc_occ == tcClsName
  = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
  | otherwise
  = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
  where 
    tc_occ   = rdrNameOcc tc


----------------------------------------------------------------------------
-- Various Syntactic Checks

checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t 
  = case t of
	HsForAllTy tvs ctxt ty ->
		checkDictTy ty [] `thenP` \ dict_ty ->
	      	returnP (HsForAllTy tvs ctxt dict_ty)

	ty ->   checkDictTy ty [] `thenP` \ dict_ty->
	      	returnP (HsForAllTy Nothing [] dict_ty)

checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (HsTupleTy _ ts) 
  = mapP (\t -> checkPred t []) ts `thenP` \ps ->
    returnP ps
checkContext (HsTyVar t) -- empty contexts are allowed
  | t == unitTyCon_RDR = returnP []
checkContext t 
  = checkPred t [] `thenP` \p ->
    returnP [p]

checkPred :: RdrNameHsType -> [RdrNameHsType] 
	-> P (HsPred RdrName)
checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
  	= returnP (HsClassP t args)
checkPred (HsAppTy l r) args = checkPred l (r:args)
checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
checkPred _ _ = parseError "Illegal class assertion"

checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
  	= returnP (mkHsDictTy t args)
checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
checkDictTy _ _ = parseError "Malformed context in instance header"

-- Put more comments!
-- Checks that the lhs of a datatype declaration
-- is of the form Context => T a b ... z
checkDataHeader :: RdrNameHsType 
	-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])

checkDataHeader (HsForAllTy Nothing cs t) =
   checkSimple t []	     `thenP` \(c,ts) ->
   returnP (cs,c,map UserTyVar ts)
checkDataHeader t =
   checkSimple t []	     `thenP` \(c,ts) ->
   returnP ([],c,map UserTyVar ts)

-- Checks the type part of the lhs of a datatype declaration
checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a 
   = checkSimple l (a:xs)
checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)

checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] 
  | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
  = returnP (tycon,[t1,t2])

checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"

---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- 	We parse   do { e1 ; e2 ; }
-- 	as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
--	   (b) transforms it to a ResultStmt

checkDo []	       = parseError "Empty 'do' construct"
checkDo [ExprStmt e l] = returnP [ResultStmt e l]
checkDo [s] 	       = parseError "The last statment in a 'do' construct must be an expression"
checkDo (s:ss)	       = checkDo ss	`thenP` \ ss' ->
			 returnP (s:ss')

---------------------------------------------------------------------------
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
checkPattern loc e = setSrcLocP loc (checkPat e [])

checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
checkPatterns loc es = mapP (checkPattern loc) es

checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
checkPat (HsApp f x) args = 
	checkPat x [] `thenP` \x ->
	checkPat f (x:args)
checkPat e [] = case e of
	EWildPat	   -> returnP WildPatIn
	HsVar x		   -> returnP (VarPatIn x)<commit_msg>[project @ 2001-07-05 08:55:29 by simonpj] Correct spelling in error message<commit_after>%
% (c) The GRASP/AQUA Project, Glasgow University, 1999
%
\section[ParseUtil]{Parser Utilities}

\begin{code}
module ParseUtil (
	  parseError		-- String -> Pa
	, cbot			-- a
	, mkVanillaCon, mkRecCon,

	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp
	, groupBindings
	
	, mkExtName             -- RdrName -> ExtName

	, checkPrec 		-- String -> P String
	, checkContext		-- HsType -> P HsContext
	, checkInstType		-- HsType -> P HsType
	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
	, checkSimple		-- HsType -> [HsName] -> P ((HsName,[HsName]))
	, checkPattern		-- HsExp -> P HsPat
	, checkPatterns		-- SrcLoc -> [HsExp] -> P [HsPat]
	, checkDo		-- [HsStmt] -> P [HsStmt]
	, checkValDef		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
	, checkValSig		-- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
 ) where

#include "HsVersions.h"

import Lex
import HsSyn		-- Lots of it
import SrcLoc
import RdrHsSyn		( RdrBinding(..),
			  RdrNameHsType, RdrNameBangType, RdrNameContext,
			  RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
			  RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
			)
import RdrName
import PrelNames	( unitTyCon_RDR )
import OccName  	( dataName, varName, tcClsName,
			  occNameSpace, setOccNameSpace, occNameUserString )
import CStrings		( CLabelString )
import FastString	( unpackFS )
import Outputable

-----------------------------------------------------------------------------
-- Misc utils

parseError :: String -> P a
parseError s = 
  getSrcLocP `thenP` \ loc ->
  failMsgP (hcat [ppr loc, text ": ", text s])

cbot = panic "CCall:result_ty"

-----------------------------------------------------------------------------
-- mkVanillaCon

-- When parsing data declarations, we sometimes inadvertently parse
-- a constructor application as a type (eg. in data T a b = C a b `D` E a b)
-- This function splits up the type application, adds any pending
-- arguments, and converts the type constructor back into a data constructor.

mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails)

mkVanillaCon ty tys
 = split ty tys
 where
   split (HsAppTy t u)  ts = split t (unbangedType u : ts)
   split (HsTyVar tc)   ts = tyConToDataCon tc	`thenP` \ data_con ->
			     returnP (data_con, VanillaCon ts)
   split _		 _ = parseError "Illegal data/newtype declaration"

mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails)
mkRecCon con fields
  = tyConToDataCon con	`thenP` \ data_con ->
    returnP (data_con, RecCon fields)

tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
  | occNameSpace tc_occ == tcClsName
  = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName))
  | otherwise
  = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc)))
  where 
    tc_occ   = rdrNameOcc tc


----------------------------------------------------------------------------
-- Various Syntactic Checks

checkInstType :: RdrNameHsType -> P RdrNameHsType
checkInstType t 
  = case t of
	HsForAllTy tvs ctxt ty ->
		checkDictTy ty [] `thenP` \ dict_ty ->
	      	returnP (HsForAllTy tvs ctxt dict_ty)

	ty ->   checkDictTy ty [] `thenP` \ dict_ty->
	      	returnP (HsForAllTy Nothing [] dict_ty)

checkContext :: RdrNameHsType -> P RdrNameContext
checkContext (HsTupleTy _ ts) 
  = mapP (\t -> checkPred t []) ts `thenP` \ps ->
    returnP ps
checkContext (HsTyVar t) -- empty contexts are allowed
  | t == unitTyCon_RDR = returnP []
checkContext t 
  = checkPred t [] `thenP` \p ->
    returnP [p]

checkPred :: RdrNameHsType -> [RdrNameHsType] 
	-> P (HsPred RdrName)
checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
  	= returnP (HsClassP t args)
checkPred (HsAppTy l r) args = checkPred l (r:args)
checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
checkPred _ _ = parseError "Illegal class assertion"

checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) 
  	= returnP (mkHsDictTy t args)
checkDictTy (HsAppTy l r) args = checkDictTy l (r:args)
checkDictTy _ _ = parseError "Malformed context in instance header"

-- Put more comments!
-- Checks that the lhs of a datatype declaration
-- is of the form Context => T a b ... z
checkDataHeader :: RdrNameHsType 
	-> P (RdrNameContext, RdrName, [RdrNameHsTyVar])

checkDataHeader (HsForAllTy Nothing cs t) =
   checkSimple t []	     `thenP` \(c,ts) ->
   returnP (cs,c,map UserTyVar ts)
checkDataHeader t =
   checkSimple t []	     `thenP` \(c,ts) ->
   returnP ([],c,map UserTyVar ts)

-- Checks the type part of the lhs of a datatype declaration
checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName]))
checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a 
   = checkSimple l (a:xs)
checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs)

checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] 
  | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2
  = returnP (tycon,[t1,t2])

checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration"

---------------------------------------------------------------------------
-- Checking statements in a do-expression
-- 	We parse   do { e1 ; e2 ; }
-- 	as [ExprStmt e1, ExprStmt e2]
-- checkDo (a) checks that the last thing is an ExprStmt
--	   (b) transforms it to a ResultStmt

checkDo []	       = parseError "Empty 'do' construct"
checkDo [ExprStmt e l] = returnP [ResultStmt e l]
checkDo [s] 	       = parseError "The last statement in a 'do' construct must be an expression"
checkDo (s:ss)	       = checkDo ss	`thenP` \ ss' ->
			 returnP (s:ss')

---------------------------------------------------------------------------
-- Checking Patterns.

-- We parse patterns as expressions and check for valid patterns below,
-- converting the expression into a pattern at the same time.

checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat
checkPattern loc e = setSrcLocP loc (checkPat e [])

checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat]
checkPatterns loc es = mapP (checkPattern loc) es

checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat
checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args)
checkPat (HsApp f x) args = 
	checkPat x [] `thenP` \x ->
	checkPat f (x:args)
checkPat e [] = case e of
	EWildPat	   -> returnP WildPatIn
	HsVar x		   -> returnP (VarPatIn x)
{'fraction_non_alphanumeric': 0.16458140253320977, 'fraction_numerical': 0.003243744207599629, 'mean_word_length': 2.747901591895803, 'pattern_counts': {'":': 2, '<': 5, '<?xml version=': 0, '>': 113, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5504727', 'n_tokens_mistral': 4729, 'n_tokens_neox': 4472, 'n_words': 1370}