+ -- The parser left-associates, so there should
+ -- not be any OpApps inside the e's
+splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName])
+-- Splits (f ! g a b) into (f, [(! g), a, g])
+splitBang (L loc (OpApp l_arg bang@(L loc' (HsVar op)) _ r_arg))
+ | op == bang_RDR = Just (l_arg, L loc (SectionR bang arg1) : argns)
+ where
+ (arg1,argns) = split_bang r_arg []
+ split_bang (L _ (HsApp f e)) es = split_bang f (e:es)
+ split_bang e es = (e,es)
+splitBang other = Nothing
+
+isFunLhs :: LHsExpr RdrName
+ -> P (Maybe (Located RdrName, Bool, [LHsExpr RdrName]))
+-- Just (fun, is_infix, arg_pats) if e is a function LHS
+isFunLhs e = go e []
+ where
+ go (L loc (HsVar f)) es
+ | not (isRdrDataCon f) = return (Just (L loc f, False, es))
+ go (L _ (HsApp f e)) es = go f (e:es)
+ go (L _ (HsPar e)) es@(_:_) = go e es
+ go e@(L loc (OpApp l (L loc' (HsVar op)) fix r)) es
+ | Just (e',es') <- splitBang e
+ = do { bang_on <- extension bangPatEnabled
+ ; if bang_on then go e' (es' ++ es)
+ else return (Just (L loc' op, True, (l:r:es))) }
+ -- No bangs; behave just like the next case
+ | not (isRdrDataCon op)
+ = return (Just (L loc' op, True, (l:r:es)))
+ | otherwise
+ = do { mb_l <- go l es
+ ; case mb_l of
+ Just (op', True, j : k : es')
+ -> return (Just (op', True, j : op_app : es'))
+ where
+ op_app = L loc (OpApp k (L loc' (HsVar op)) fix r)
+ _ -> return Nothing }
+ go _ _ = return 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))