+ go (HsTyVar tc) acc
+ | not (isRdrTyVar tc) = checkTyVars acc `thenP` \ tvs ->
+ returnP (tc, tvs)
+ go (HsOpTy t1 (HsTyOp tc) t2) acc
+ = checkTyVars (t1:t2:acc) `thenP` \ tvs ->
+ returnP (tc, tvs)
+ go (HsParTy ty) acc = go ty acc
+ go (HsAppTy t1 t2) acc = go t1 (t2:acc)
+ go other acc = parseError "Malformed LHS to type of class declaration"
+
+checkContext :: RdrNameHsType -> P RdrNameContext
+checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type
+ = mapP checkPred ts
+
+checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way
+ = checkContext ty
+
+checkContext (HsTyVar t) -- Empty context shows up as a unit type ()
+ | t == getRdrName unitTyCon = returnP []
+
+checkContext t
+ = checkPred t `thenP` \p ->
+ returnP [p]
+
+checkPred :: RdrNameHsType -> P (HsPred RdrName)
+-- Watch out.. in ...deriving( Show )... we use checkPred on
+-- the list of partially applied predicates in the deriving,
+-- so there can be zero args.
+checkPred (HsPredTy (HsIParam n ty)) = returnP (HsIParam n ty)
+checkPred ty
+ = go ty []
+ where
+ go (HsTyVar t) args | not (isRdrTyVar t)
+ = returnP (HsClassP t args)
+ go (HsAppTy l r) args = go l (r:args)
+ go (HsParTy t) args = go t args
+ go _ _ = 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 (HsParTy t) args = checkDictTy t args
+checkDictTy _ _ = parseError "Malformed context in instance header"
+
+
+---------------------------------------------------------------------------
+-- 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
+-- same comments apply for mdo as well
+
+checkDo = checkDoMDo "a " "'do'"
+checkMDo = checkDoMDo "an " "'mdo'"
+
+checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct"
+checkDoMDo _ _ [ExprStmt e _ l] = returnP [ResultStmt e l]
+checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression"
+checkDoMDo pre nm (s:ss) = checkDoMDo pre nm 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 (PrefixCon args))
+checkPat (HsApp f x) args =
+ checkPat x [] `thenP` \x ->
+ checkPat f (x:args)
+checkPat e [] = case e of
+ EWildPat -> returnP (WildPat placeHolderType)
+ HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x)
+ | otherwise -> returnP (VarPat x)
+ HsLit l -> returnP (LitPat l)
+ HsOverLit l -> returnP (NPatIn l Nothing)
+ ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat)
+ EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n)
+ ExprWithTySig e t -> checkPat e [] `thenP` \e ->
+ -- Pattern signatures are parsed as sigtypes,
+ -- but they aren't explicit forall points. Hence
+ -- we have to remove the implicit forall here.
+ let t' = case t of
+ HsForAllTy Nothing [] ty -> ty
+ other -> other
+ in
+ returnP (SigPatIn e t')
+
+ -- Translate out NegApps of literals in patterns. We negate
+ -- the Integer here, and add back the call to 'negate' when
+ -- we typecheck the pattern.
+ -- NB. Negative *primitive* literals are already handled by
+ -- RdrHsSyn.mkHsNegApp
+ NegApp (HsOverLit lit) neg -> returnP (NPatIn lit (Just neg))
+
+ OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _))
+ | plus == plus_RDR
+ -> returnP (mkNPlusKPat n lit)
+ where
+ plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+
+ OpApp l op fix r -> checkPat l [] `thenP` \l ->
+ checkPat r [] `thenP` \r ->
+ case op of
+ HsVar c | isDataOcc (rdrNameOcc c)
+ -> returnP (ConPatIn c (InfixCon l r))
+ _ -> patFail
+
+ HsPar e -> checkPat e [] `thenP` (returnP . ParPat)
+ ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (PArrPat ps placeHolderType)
+
+ ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps ->
+ returnP (TuplePat ps b)
+
+ RecordCon c fs -> mapP checkPatField fs `thenP` \fs ->
+ returnP (ConPatIn c (RecCon fs))
+-- Generics
+ HsType ty -> returnP (TypePat ty)
+ _ -> patFail
+
+checkPat _ _ = patFail
+
+checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat)
+checkPatField (n,e) = checkPat e [] `thenP` \p ->
+ returnP (n,p)
+
+patFail = parseError "Parse error in pattern"
+
+
+---------------------------------------------------------------------------
+-- Check Equation Syntax
+
+checkValDef
+ :: RdrNameHsExpr
+ -> Maybe RdrNameHsType
+ -> RdrNameGRHSs
+ -> SrcLoc
+ -> P RdrBinding
+
+checkValDef lhs opt_sig grhss loc
+ = case isFunLhs lhs [] of
+ Just (f,inf,es)
+ | isQual f
+ -> parseError ("Qualified name in function definition: " ++ showRdrName f)
+ | otherwise
+ -> checkPatterns loc es `thenP` \ps ->
+ returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
+
+ Nothing ->
+ checkPattern loc lhs `thenP` \lhs ->
+ returnP (RdrValBinding (PatMonoBind lhs grhss loc))
+
+checkValSig
+ :: RdrNameHsExpr
+ -> RdrNameHsType
+ -> SrcLoc
+ -> P RdrBinding
+checkValSig (HsVar v) ty loc | isUnqual v = returnP (RdrHsDecl (SigD (Sig v ty loc)))
+checkValSig other ty loc = parseError "Type signature given for an expression"
+
+mkSigDecls :: [Sig RdrName] -> RdrBinding
+mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs]
+
+
+-- A variable binding is parsed as an RdrNameFunMonoBind.
+-- See comments with HsBinds.MonoBinds
+
+isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr])
+isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op)
+ = Just (op, True, (l:r:es))
+ | otherwise
+ = case isFunLhs l es of
+ Just (op', True, j : k : es') ->
+ Just (op', True, j : OpApp k (HsVar op) fix r : es')
+ _ -> Nothing
+isFunLhs (HsVar f) es | not (isRdrDataCon f)
+ = Just (f,False,es)
+isFunLhs (HsApp f e) es = isFunLhs f (e:es)
+isFunLhs (HsPar e) es@(_:_) = isFunLhs e es
+isFunLhs _ _ = Nothing
+
+---------------------------------------------------------------------------
+-- Miscellaneous utilities
+
+checkPrecP :: Int -> P Int
+checkPrecP i | 0 <= i && i <= maxPrecedence = returnP i
+ | otherwise = parseError "Precedence out of range"
+
+mkRecConstrOrUpdate
+ :: RdrNameHsExpr
+ -> RdrNameHsRecordBinds
+ -> P RdrNameHsExpr
+
+mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c
+ = returnP (RecordCon c fs)
+mkRecConstrOrUpdate exp fs@(_:_)
+ = returnP (RecordUpd exp fs)
+mkRecConstrOrUpdate _ _
+ = parseError "Empty record update"
+
+-----------------------------------------------------------------------------
+-- utilities for foreign declarations
+
+-- supported calling conventions
+--
+data CallConv = CCall CCallConv -- ccall or stdcall
+ | DNCall -- .NET
+
+-- construct a foreign import declaration
+--
+mkImport :: CallConv
+ -> Safety
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkImport (CCall cconv) safety (entity, v, ty) loc =
+ parseCImport entity cconv safety v `thenP` \importSpec ->
+ returnP $ ForD (ForeignImport v ty importSpec False loc)
+mkImport (DNCall ) _ (entity, v, ty) loc =
+ parseDImport entity `thenP` \ spec ->
+ returnP $ ForD (ForeignImport v ty (DNImport spec) False loc)
+
+-- parse the entity string of a foreign import declaration for the `ccall' or
+-- `stdcall' calling convention'
+--
+parseCImport :: FastString
+ -> CCallConv
+ -> Safety
+ -> RdrName
+ -> P ForeignImport
+parseCImport entity cconv safety v
+ -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
+ | entity == FSLIT ("dynamic") =
+ returnP $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ | entity == FSLIT ("wrapper") =
+ returnP $ CImport cconv safety nilFS nilFS CWrapper
+ | otherwise = parse0 (unpackFS entity)
+ where
+ -- using the static keyword?
+ parse0 (' ': rest) = parse0 rest
+ parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
+ parse0 rest = parse1 rest
+ -- check for header file name
+ parse1 "" = parse4 "" nilFS False nilFS
+ parse1 (' ':rest) = parse1 rest
+ parse1 str@('&':_ ) = parse2 str nilFS
+ parse1 str@('[':_ ) = parse3 str nilFS False
+ parse1 str
+ | ".h" `isSuffixOf` first = parse2 rest (mkFastString first)
+ | otherwise = parse4 str nilFS False nilFS
+ where
+ (first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
+ -- check for address operator (indicating a label import)
+ parse2 "" header = parse4 "" header False nilFS
+ parse2 (' ':rest) header = parse2 rest header
+ parse2 ('&':rest) header = parse3 rest header True
+ parse2 str@('[':_ ) header = parse3 str header False
+ parse2 str header = parse4 str header False nilFS
+ -- check for library object name
+ parse3 (' ':rest) header isLbl = parse3 rest header isLbl
+ parse3 ('[':rest) header isLbl =
+ case break (== ']') rest of
+ (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib)
+ _ -> parseError "Missing ']' in entity"
+ parse3 str header isLbl = parse4 str header isLbl nilFS
+ -- check for name of C function
+ parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
+ parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
+ parse4 str header isLbl lib
+ | all (== ' ') rest = build (mkFastString first) header isLbl lib
+ | otherwise = parseError "Malformed entity string"
+ where
+ (first, rest) = break (== ' ') str
+ --
+ build cid header False lib = returnP $
+ CImport cconv safety header lib (CFunction (StaticTarget cid))
+ build cid header True lib = returnP $
+ CImport cconv safety header lib (CLabel cid )
+
+--
+-- Unravel a dotnet spec string.
+--
+parseDImport :: FastString -> P DNCallSpec
+parseDImport entity = parse0 comps
+ where
+ comps = words (unpackFS entity)
+
+ parse0 [] = d'oh
+ parse0 (x : xs)
+ | x == "static" = parse1 True xs
+ | otherwise = parse1 False (x:xs)
+
+ parse1 _ [] = d'oh
+ parse1 isStatic (x:xs)
+ | x == "method" = parse2 isStatic DNMethod xs
+ | x == "field" = parse2 isStatic DNField xs
+ | x == "ctor" = parse2 isStatic DNConstructor xs
+ parse1 isStatic xs = parse2 isStatic DNMethod xs
+
+ parse2 _ _ [] = d'oh
+ parse2 isStatic kind (('[':x):xs) =
+ case x of
+ [] -> d'oh
+ vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
+ parse2 isStatic kind xs = parse3 isStatic kind "" xs
+
+ parse3 isStatic kind assem [x] =
+ returnP (DNCallSpec isStatic kind assem x
+ -- these will be filled in once known.
+ (error "FFI-dotnet-args")
+ (error "FFI-dotnet-result"))
+ parse3 _ _ _ _ = d'oh
+
+ d'oh = parseError "Malformed entity string"
+
+-- construct a foreign export declaration
+--
+mkExport :: CallConv
+ -> (FastString, RdrName, RdrNameHsType)
+ -> SrcLoc
+ -> P RdrNameHsDecl
+mkExport (CCall cconv) (entity, v, ty) loc = returnP $
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
+ where
+ entity' | nullFastString entity = mkExtName v
+ | otherwise = entity
+mkExport DNCall (entity, v, ty) loc =
+ parseError "Foreign export is not yet supported for .NET"
+
+-- Supplying the ext_name in a foreign decl is optional; if it
+-- isn't there, the Haskell name is assumed. Note that no transformation
+-- of the Haskell name is then performed, so if you foreign export (++),
+-- it's external name will be "++". Too bad; it's important because we don't
+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
+-- (This is why we use occNameUserString.)
+--
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm))
+
+-- ---------------------------------------------------------------------------
+-- Make the export list for an interface
+
+mkIfaceExports :: [RdrNameTyClDecl] -> [RdrAvailInfo]
+mkIfaceExports decls = map getExport decls
+ where getExport d = case d of
+ TyData{} -> tc_export
+ ClassDecl{} -> tc_export
+ _other -> var_export
+ where
+ tc_export = AvailTC (rdrNameOcc (tcdName d))
+ (map (rdrNameOcc.fst) (tyClDeclNames d))
+ var_export = Avail (rdrNameOcc (tcdName d))
+\end{code}
+
+
+-----------------------------------------------------------------------------
+-- Misc utils
+
+\begin{code}
+showRdrName :: RdrName -> String
+showRdrName r = showSDoc (ppr r)
+
+parseError :: String -> P a
+parseError s =
+ getSrcLocP `thenP` \ loc ->
+ failMsgP (hcat [ppr loc, text ": ", text s])