+checkDictTy :: LHsType RdrName -> P (LHsType RdrName)
+checkDictTy (L spn ty) = check ty []
+ where
+ check (HsTyVar t) args | not (isRdrTyVar t)
+ = return (L spn (HsPredTy (HsClassP t args)))
+ check (HsAppTy l r) args = check (unLoc l) (r:args)
+ check (HsParTy t) args = check (unLoc t) args
+ check _ _ = parseError spn "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) returns it separately
+-- same comments apply for mdo as well
+
+checkDo = checkDoMDo "a " "'do'"
+checkMDo = checkDoMDo "an " "'mdo'"
+
+checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName)
+checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct")
+checkDoMDo pre nm loc ss = do
+ check ss
+ where
+ check [L l (ExprStmt e _ _)] = return ([], e)
+ check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++
+ " construct must be an expression")
+ check (s:ss) = do
+ (ss',e') <- check ss
+ return ((s:ss'),e')
+
+-- -------------------------------------------------------------------------
+-- Checking Patterns.
+
+-- We parse patterns as expressions and check for valid patterns below,
+-- converting the expression into a pattern at the same time.
+
+checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
+checkPattern e = checkLPat e
+
+checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
+checkPatterns es = mapM checkPattern es
+
+checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
+checkLPat e@(L l _) = checkPat l e []
+
+checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
+checkPat loc (L l (HsVar c)) args
+ | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
+checkPat loc (L _ (HsApp f x)) args = do
+ x <- checkLPat x
+ checkPat loc f (x:args)
+checkPat loc (L _ e) [] = do
+ p <- checkAPat loc e
+ return (L loc p)
+checkPat loc pat _some_args
+ = patFail loc
+
+checkAPat loc e = case e of
+ EWildPat -> return (WildPat placeHolderType)
+ HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: "
+ ++ showRdrName x)
+ | otherwise -> return (VarPat x)
+ HsLit l -> return (LitPat l)
+
+ -- Overloaded numeric patterns (e.g. f 0 x = x)
+ -- Negation is recorded separately, so that the literal is zero or +ve
+ -- NB. Negative *primitive* literals are already handled by
+ -- RdrHsSyn.mkHsNegApp
+ HsOverLit pos_lit -> return (mkNPat pos_lit Nothing)
+ NegApp (L _ (HsOverLit pos_lit)) _
+ -> return (mkNPat pos_lit (Just noSyntaxExpr))
+
+ ELazyPat e -> checkLPat e >>= (return . LazyPat)
+ EAsPat n e -> checkLPat e >>= (return . AsPat n)
+ ExprWithTySig e t -> checkLPat e >>= \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
+ L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty
+ other -> other
+ in
+ return (SigPatIn e t')
+
+ -- n+k patterns
+ OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _
+ (L _ (HsOverLit lit@(HsIntegral _ _)))
+ | plus == plus_RDR
+ -> return (mkNPlusKPat (L nloc n) lit)
+ where
+ plus_RDR = mkUnqual varName FSLIT("+") -- Hack
+
+ OpApp l op fix r -> checkLPat l >>= \l ->
+ checkLPat r >>= \r ->
+ case op of
+ L cl (HsVar c) | isDataOcc (rdrNameOcc c)
+ -> return (ConPatIn (L cl c) (InfixCon l r))
+ _ -> patFail loc
+
+ HsPar e -> checkLPat e >>= (return . ParPat)
+ ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
+ return (ListPat ps placeHolderType)
+ ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps ->
+ return (PArrPat ps placeHolderType)
+
+ ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
+ return (TuplePat ps b)
+
+ RecordCon c _ fs -> mapM checkPatField fs >>= \fs ->
+ return (ConPatIn c (RecCon fs))
+-- Generics
+ HsType ty -> return (TypePat ty)
+ _ -> patFail loc
+
+checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
+checkPatField (n,e) = do
+ p <- checkLPat e
+ return (n,p)
+
+patFail loc = parseError loc "Parse error in pattern"
+
+
+---------------------------------------------------------------------------
+-- Check Equation Syntax
+
+checkValDef
+ :: LHsExpr RdrName
+ -> Maybe (LHsType RdrName)
+ -> Located (GRHSs RdrName)
+ -> P (HsBind RdrName)
+
+checkValDef lhs opt_sig (L rhs_span grhss)
+ | Just (f,inf,es) <- isFunLhs lhs []
+ = if isQual (unLoc f)
+ then parseError (getLoc f) ("Qualified name in function definition: " ++
+ showRdrName (unLoc f))
+ else do ps <- checkPatterns es
+ let match_span = combineSrcSpans (getLoc lhs) rhs_span
+ matches = mkMatchGroup [L match_span (Match ps opt_sig grhss)]
+ return (FunBind f inf matches placeHolderNames)
+ -- The span of the match covers the entire equation.
+ -- That isn't quite right, but it'll do for now.
+ | otherwise = do
+ lhs <- checkPattern lhs
+ return (PatBind lhs grhss placeHolderType placeHolderNames)
+
+checkValSig
+ :: LHsExpr RdrName
+ -> LHsType RdrName
+ -> P (Sig RdrName)
+checkValSig (L l (HsVar v)) ty | isUnqual v = return (TypeSig (L l v) ty)
+checkValSig (L l other) ty
+ = parseError l "Type signature given for an expression"
+
+mkGadtDecl
+ :: Located RdrName
+ -> LHsType RdrName -- assuming HsType
+ -> ConDecl RdrName
+mkGadtDecl name (L _ (HsForAllTy _ qvars cxt ty)) = ConDecl
+ { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = qvars
+ , con_cxt = cxt
+ , con_details = PrefixCon args
+ , con_res = ResTyGADT res
+ }
+ where
+ (args, res) = splitHsFunType ty
+mkGadtDecl name ty = ConDecl
+ { con_name = name
+ , con_explicit = Implicit
+ , con_qvars = []
+ , con_cxt = noLoc []
+ , con_details = PrefixCon args
+ , con_res = ResTyGADT res
+ }
+ where
+ (args, res) = splitHsFunType ty
+
+-- A variable binding is parsed as a FunBind.
+
+isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName]
+ -> Maybe (Located RdrName, Bool, [LHsExpr RdrName])
+isFunLhs (L loc e) = isFunLhs' loc e
+ where
+ isFunLhs' loc (HsVar f) es
+ | not (isRdrDataCon f) = Just (L loc f, False, es)
+ isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es)
+ isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es
+ isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es
+ | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es))
+ | otherwise =
+ case isFunLhs l es of
+ Just (op', True, j : k : es') ->
+ Just (op', True,
+ j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es')
+ _ -> Nothing
+ isFunLhs' _ _ _ = Nothing
+
+---------------------------------------------------------------------------
+-- Miscellaneous utilities
+
+checkPrecP :: Located Int -> P Int
+checkPrecP (L l i)
+ | 0 <= i && i <= maxPrecedence = return i
+ | otherwise = parseError l "Precedence out of range"
+
+mkRecConstrOrUpdate
+ :: LHsExpr RdrName
+ -> SrcSpan
+ -> HsRecordBinds RdrName
+ -> P (HsExpr RdrName)
+
+mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
+ = return (RecordCon (L l c) noPostTcExpr fs)
+mkRecConstrOrUpdate exp loc fs@(_:_)
+ = return (RecordUpd exp fs placeHolderType placeHolderType)
+mkRecConstrOrUpdate _ loc []
+ = parseError loc "Empty record update"
+
+mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
+-- The Maybe is becuase the user can omit the activation spec (and usually does)
+mkInlineSpec Nothing True = alwaysInlineSpec -- INLINE
+mkInlineSpec Nothing False = neverInlineSpec -- NOINLINE
+mkInlineSpec (Just act) inl = Inline act inl
+
+
+-----------------------------------------------------------------------------
+-- utilities for foreign declarations
+
+-- supported calling conventions
+--
+data CallConv = CCall CCallConv -- ccall or stdcall
+ | DNCall -- .NET
+
+-- construct a foreign import declaration
+--
+mkImport :: CallConv
+ -> Safety
+ -> (Located FastString, Located RdrName, LHsType RdrName)
+ -> P (HsDecl RdrName)
+mkImport (CCall cconv) safety (entity, v, ty) = do
+ importSpec <- parseCImport entity cconv safety v
+ return (ForD (ForeignImport v ty importSpec False))
+mkImport (DNCall ) _ (entity, v, ty) = do
+ spec <- parseDImport entity
+ return $ ForD (ForeignImport v ty (DNImport spec) False)
+
+-- parse the entity string of a foreign import declaration for the `ccall' or
+-- `stdcall' calling convention'
+--
+parseCImport :: Located FastString
+ -> CCallConv
+ -> Safety
+ -> Located RdrName
+ -> P ForeignImport
+parseCImport (L loc entity) cconv safety v
+ -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
+ | entity == FSLIT ("dynamic") =
+ return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget)
+ | entity == FSLIT ("wrapper") =
+ return $ 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 loc "Missing ']' in entity"
+ parse3 str header isLbl = parse4 str header isLbl nilFS
+ -- check for name of C function
+ parse4 "" header isLbl lib = build (mkExtName (unLoc 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 loc "Malformed entity string"
+ where
+ (first, rest) = break (== ' ') str
+ --
+ build cid header False lib = return $
+ CImport cconv safety header lib (CFunction (StaticTarget cid))
+ build cid header True lib = return $
+ CImport cconv safety header lib (CLabel cid )
+
+--
+-- Unravel a dotnet spec string.
+--
+parseDImport :: Located FastString -> P DNCallSpec
+parseDImport (L loc 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] =
+ return (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 loc "Malformed entity string"
+
+-- construct a foreign export declaration
+--
+mkExport :: CallConv
+ -> (Located FastString, Located RdrName, LHsType RdrName)
+ -> P (HsDecl RdrName)
+mkExport (CCall cconv) (L loc entity, v, ty) = return $
+ ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False)
+ where
+ entity' | nullFS entity = mkExtName (unLoc v)
+ | otherwise = entity
+mkExport DNCall (L loc entity, v, ty) =
+ parseError (getLoc v){-TODO: not quite right-}
+ "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)
+--
+mkExtName :: RdrName -> CLabelString
+mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))