- :: 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
+ :: LHsExpr RdrName
+ -> LHsType RdrName
+ -> P (Sig RdrName)
+checkValSig (L l (HsVar v)) ty
+ | isUnqual v && not (isDataOcc (rdrNameOcc v))
+ = return (TypeSig (L l v) ty)
+checkValSig (L l other) ty
+ = parseError l "Invalid type signature"
+
+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.
+
+
+ -- 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