{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : Language.Haskell.Exts.ParseUtils -- Copyright : (c) Niklas Broberg 2004-2009, -- (c) The GHC Team, 1997-2000 -- License : BSD-style (see the file LICENSE.txt) -- -- Maintainer : Niklas Broberg, d00nibro@chalmers.se -- Stability : stable -- Portability : portable -- -- Utilities for the Haskell-exts parser. -- ----------------------------------------------------------------------------- module Language.Haskell.Exts.ParseUtils ( splitTyConApp -- PType -> P (Name,[Type]) , checkEnabled -- (Show e, Enabled e) => e -> P () , checkPatternGuards -- [Stmt] -> P () , mkRecConstrOrUpdate -- PExp -> [PFieldUpdate] -> P Exp , checkPrec -- Integer -> P Int , checkPContext -- PType -> P PContext , checkContext -- PContext -> P Context , checkAssertion -- PType -> P PAsst , checkDataHeader -- PType -> P (Context,Name,[TyVarBind]) , checkClassHeader -- PType -> P (Context,Name,[TyVarBind]) , checkInstHeader -- PType -> P (Context,QName,[Type]) , checkDeriving -- [PType] -> P [Deriving] , checkPattern -- PExp -> P Pat , checkExpr -- PExp -> P Exp , checkType -- PType -> P Type , checkValDef -- SrcLoc -> PExp -> Maybe Type -> Rhs -> Binds -> P Decl , checkClassBody -- [ClassDecl] -> P [ClassDecl] , checkInstBody -- [InstDecl] -> P [InstDecl] , checkUnQual -- QName -> P Name , checkRevDecls -- [Decl] -> P [Decl] , checkRevClsDecls -- [ClassDecl] -> P [ClassDecl] , checkRevInstDecls -- [InstDecl] -> P [InstDecl] , checkDataOrNew -- DataOrNew -> [a] -> P () , checkSimpleType -- PType -> P (Name, [TyVarBind]) , checkSigVar -- PExp -> P Name , getGConName -- S.Exp -> P QName , mkTyForall -- Maybe [TyVarBind] -> PContext -> PType -> PType -- HaRP , checkRPattern -- PExp -> P RPat -- Hsx , checkEqNames -- XName -> XName -> P XName , checkPageModule , checkHybridModule , mkDVar -- [String] -> String -- Pragmas , checkRuleExpr -- PExp -> P Exp , readTool -- Maybe String -> Maybe Tool -- Parsed expressions and types , PExp(..), PFieldUpdate(..), ParseXAttr(..), PType(..), PContext, PAsst(..) , p_unit_con -- PExp , p_tuple_con -- Boxed -> Int -> PExp , p_unboxed_singleton_con -- PExp ) where import Language.Haskell.Exts.Annotated.Syntax hiding ( Type(..), Asst(..), Exp(..), FieldUpdate(..), XAttr(..), Context(..) ) import qualified Language.Haskell.Exts.Annotated.Syntax as S ( Type(..), Asst(..), Exp(..), FieldUpdate(..), XAttr(..), Context(..) ) import Language.Haskell.Exts.Annotated.Build import Language.Haskell.Exts.ParseSyntax import Language.Haskell.Exts.ParseMonad import Language.Haskell.Exts.Pretty import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.Extension import Language.Haskell.Exts.ExtScheme import Data.List (intersperse) import Data.Maybe (fromJust) import Control.Monad (when,liftM) --- import Debug.Trace (trace) type L = SrcSpanInfo type S = SrcSpan splitTyConApp :: PType L -> P (Name L, [S.Type L]) splitTyConApp t0 = do (n, pts) <- split t0 [] ts <- mapM checkType pts return (n,ts) where split :: PType L -> [PType L] -> P (Name L, [PType L]) split (TyApp _ t u) ts = split t (u:ts) split (TyCon _ (UnQual _ t)) ts = return (t,ts) split (TyInfix l a op b) ts = split (TyCon l op) (a:b:ts) split _ _ = fail "Illegal data/newtype declaration" ----------------------------------------------------------------------------- -- Checking for extensions checkEnabled :: (Show e, Enabled e) => e -> P () checkEnabled e = do exts <- getExtensions if isEnabled e exts then return () else fail $ show e ++ " is not enabled" checkPatternGuards :: [Stmt L] -> P () checkPatternGuards [Qualifier _ _] = return () checkPatternGuards _ = checkEnabled PatternGuards ----------------------------------------------------------------------------- -- Checking contexts -- Check that a context is syntactically correct. Takes care of -- checking for MPTCs, TypeOperators, TypeFamilies (for eq constraints) -- and ImplicitParameters, but leaves checking of the class assertion -- parameters for later. checkPContext :: PType L -> P (PContext L) checkPContext (TyTuple l Boxed ts) = mapM checkAssertion ts >>= return . CxTuple l checkPContext (TyCon l (Special _ (UnitCon _))) = return $ CxEmpty l checkPContext (TyParen l t) = do c <- checkPContext t return $ CxParen l c checkPContext t = do c <- checkAssertion t return $ CxSingle (ann c) c ------------------------------------------------------------------------------------------------------------------- WORKING HERE -- Check a single assertion according to the above, still leaving -- the class assertion parameters for later. checkAssertion :: PType L -> P (PAsst L) -- We cannot even get here unless ImplicitParameters is enabled. checkAssertion (TyPred _ p@(IParam _ _ _)) = return p -- We cannot even get here unless TypeFamilies is enabled. checkAssertion (TyPred _ p@(EqualP _ _ _)) = return p checkAssertion t = checkAssertion' id [] t where -- class assertions must have at least one argument checkAssertion' fl ts@(_:xs) (TyCon l c) = do when (not $ null xs) $ checkEnabled MultiParamTypeClasses when (isSymbol c) $ checkEnabled TypeOperators return $ ClassA (fl l) c ts checkAssertion' fl ts (TyApp l a t) = do -- no check on t at this stage checkAssertion' (const (fl l)) (t:ts) a checkAssertion' fl ts (TyInfix l a op b) = do -- infix operators require TypeOperators checkEnabled TypeOperators return $ InfixA (fl l) a op b checkAssertion' fl ts (TyParen l t) = checkAssertion' (const (fl l)) ts t checkAssertion' _ _ _ = fail "Illegal class assertion" isSymbol :: QName L -> Bool isSymbol (UnQual _ (Symbol _ _)) = True isSymbol (Qual _ _ (Symbol _ _)) = True isSymbol _ = False -- Checks simple contexts for class and instance -- headers. If FlexibleContexts is enabled then -- anything goes, otherwise only tyvars are allowed. checkSContext :: Maybe (PContext L) -> P (Maybe (S.Context L)) checkSContext (Just ctxt) = case ctxt of CxEmpty l -> return $ Just $ S.CxEmpty l CxSingle l a -> checkAsst True a >>= return . Just . S.CxSingle l CxTuple l as -> mapM (checkAsst True) as >>= return . Just . S.CxTuple l CxParen l cx -> checkSContext (Just cx) >>= return . fmap (S.CxParen l) checkSContext _ = return Nothing -- Checks ordinary contexts for sigtypes and data type -- declarations. If FlexibleContexts is enabled then -- anything goes, otherwise only tyvars OR tyvars -- applied to types are allowed. checkContext :: Maybe (PContext L) -> P (Maybe (S.Context L)) checkContext (Just ctxt) = case ctxt of CxEmpty l -> return $ Just $ S.CxEmpty l CxSingle l a -> checkAsst False a >>= return . Just . S.CxSingle l CxTuple l as -> mapM (checkAsst False) as >>= return . Just . S.CxTuple l CxParen l cx -> checkSContext (Just cx) >>= return . fmap (S.CxParen l) checkContext _ = return Nothing checkAsst :: Bool -> PAsst L -> P (S.Asst L) checkAsst isSimple asst = case asst of ClassA l qn pts -> do ts <- mapM (checkAsstParam isSimple) pts return $ S.ClassA l qn ts InfixA l a op b -> do [a,b] <- mapM (checkAsstParam isSimple) [a,b] return $ S.InfixA l a op b IParam l ipn pt -> do t <- checkType pt return $ S.IParam l ipn t EqualP l pa pb -> do a <- checkType pa b <- checkType pb return $ S.EqualP l a b checkAsstParam :: Bool -> PType L -> P (S.Type L) checkAsstParam isSimple t = do exts <- getExtensions if FlexibleContexts `elem` exts then checkType t else case t of TyVar l n -> return $ S.TyVar l n TyApp l pf pt | not isSimple -> do f <- checkAsstParam isSimple pf t <- checkType pt return $ S.TyApp l f t _ -> fail "Malformed context: FlexibleContexts not enabled" ----------------------------------------------------------------------------- -- Checking Headers checkDataHeader :: PType L -> P (Maybe (S.Context L), DeclHead L) checkDataHeader (TyForall _ Nothing cs t) = do dh <- checkSimple "data/newtype" t [] cs <- checkContext cs return (cs,dh) checkDataHeader t = do dh <- checkSimple "data/newtype" t [] return (Nothing,dh) checkClassHeader :: PType L -> P (Maybe (S.Context L), DeclHead L) checkClassHeader (TyForall _ Nothing cs t) = do dh <- checkSimple "class" t [] cs <- checkSContext cs return (cs,dh) checkClassHeader t = do dh <- checkSimple "class" t [] return (Nothing,dh) checkSimple :: String -> PType L -> [TyVarBind L] -> P (DeclHead L) checkSimple kw (TyApp _ l t) xs | isTyVarBind t = checkSimple kw l (toTyVarBind t : xs) checkSimple _ (TyInfix l t1 (UnQual _ t) t2) [] | isTyVarBind t1 && isTyVarBind t2 = checkEnabled TypeOperators >> return (DHInfix l (toTyVarBind t1) t (toTyVarBind t2)) checkSimple _kw (TyCon l (UnQual _ t)) xs = do case t of Symbol _ _ -> checkEnabled TypeOperators _ -> return () return (DHead l t xs) checkSimple kw (TyParen l t) xs = do dh <- checkSimple kw t xs return (DHParen l dh) checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration") isTyVarBind :: PType L -> Bool isTyVarBind (TyVar _ _) = True isTyVarBind (TyKind _ (TyVar _ _) _) = True isTyVarBind _ = False toTyVarBind :: PType L -> TyVarBind L toTyVarBind (TyVar l n) = UnkindedVar l n toTyVarBind (TyKind l (TyVar _ n) k) = KindedVar l n k checkInstHeader :: PType L -> P (Maybe (S.Context L), InstHead L) checkInstHeader (TyForall _ Nothing cs t) = do ih <- checkInsts t [] cs <- checkSContext cs return (cs, ih) checkInstHeader t = do ih <- checkInsts t [] return (Nothing, ih) checkInsts :: PType L -> [PType L] -> P (InstHead L) checkInsts (TyApp _ l t) ts = checkInsts l (t:ts) checkInsts (TyCon l c) ts = do when (isSymbol c) $ checkEnabled TypeOperators ts <- checkTypes ts return $ IHead l c ts checkInsts (TyInfix l a op b) [] = do checkEnabled TypeOperators [ta,tb] <- checkTypes [a,b] return $ IHInfix l ta op tb checkInsts (TyParen l t) [] = checkInsts t [] >>= return . IHParen l checkInsts _ _ = fail "Illegal instance declaration" checkDeriving :: [PType L] -> P [InstHead L] checkDeriving = mapM (flip checkInsts []) ----------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. checkPattern :: PExp L -> P (Pat L) checkPattern e = checkPat e [] checkPat :: PExp L -> [Pat L] -> P (Pat L) checkPat (Con l c) args = return (PApp l c args) checkPat (App l f x) args = do x <- checkPat x [] checkPat f (x:args) checkPat (InfixApp _ l op r) args | op =~= (QVarOp () (UnQual () (Symbol () "!"))) = do -- We must have BangPatterns on checkEnabled BangPatterns let (e,es) = splitBang r [] ps <- mapM checkPattern (BangPat (ann op) e:es) checkPat l (ps++args) checkPat e [] = case e of Var l (UnQual _ x) -> return (PVar l x) Lit l lit -> return (PLit l lit) InfixApp loc l op r -> case op of QConOp _ c -> do l <- checkPat l [] r <- checkPat r [] return (PInfixApp loc l c r) QVarOp ppos (UnQual _ (Symbol _ "+")) -> do case (l,r) of (Var _ (UnQual _ n@(Ident _ _)), Lit _ (Int kpos k _)) -> do let pp = srcInfoSpan ppos kp = srcInfoSpan kpos return (PNPlusK (loc <** [pp,kp]) n k) _ -> patFail "" _ -> patFail "" TupleSection l mes -> if not (any ((==) Nothing) mes) then do ps <- mapM (\e -> checkPat e []) (map fromJust mes) return (PTuple l ps) else fail "Illegal tuple section in pattern" List l es -> do ps <- mapM checkRPattern es if all isStdPat ps then return . PList l $ map stripRP ps -- we don't allow truly regular patterns unless the extension is enabled else checkEnabled RegularPatterns >> return (PRPat l $ map fixRPOpPrec ps) where isStdPat :: RPat L -> Bool isStdPat (RPPat _ _) = True isStdPat (RPAs _ _ p) = isStdPat p isStdPat (RPParen _ p) = isStdPat p isStdPat _ = False stripRP :: RPat L -> Pat L stripRP (RPPat _ p) = p stripRP (RPAs l n p) = PAsPat l n (stripRP p) stripRP (RPParen l p) = PParen l (stripRP p) stripRP _ = error "cannot strip RP wrapper if not all patterns are base" Paren l e -> do p <- checkPat e [] return (PParen l p) AsPat l n e -> do p <- checkPat e [] return (PAsPat l n p) WildCard l -> return (PWildCard l) IrrPat l e -> do p <- checkPat e [] return (PIrrPat l p) ViewPat l e p -> do e <- checkExpr e p <- checkPat p [] return (PViewPat l e p) RecConstr l c fs -> do fs <- mapM checkPatField fs return (PRec l c fs) NegApp l1 (Lit l2 lit) -> return (PNeg l1 (PLit l2 lit)) ExpTypeSig l e t -> do -- patterns cannot have signatures unless ScopedTypeVariables is enabled. checkEnabled ScopedTypeVariables p <- checkPat e [] return (PatTypeSig l p t) -- Hsx XTag l n attrs mattr cs -> do pattrs <- mapM checkPAttr attrs pcs <- mapM (\c -> checkPat c []) cs mpattr <- maybe (return Nothing) (\e -> do p <- checkPat e [] return $ Just p) mattr let cps = mkChildrenPat pcs return $ PXTag l n pattrs mpattr cps XETag l n attrs mattr -> do pattrs <- mapM checkPAttr attrs mpattr <- maybe (return Nothing) (\e -> do p <- checkPat e [] return $ Just p) mattr return $ PXETag l n pattrs mpattr XPcdata l pcdata -> return $ PXPcdata l pcdata XExpTag l e -> do p <- checkPat e [] return $ PXPatTag l p XRPats l es -> do rps <- mapM checkRPattern es return (PXRPats l $ map fixRPOpPrec rps) -- Generics ExplTypeArg l qn t -> return $ PExplTypeArg l qn t -- QuasiQuotation QuasiQuote l n q -> return $ PQuasiQuote l n q -- BangPatterns BangPat l e -> do p <- checkPat e [] return $ PBangPat l p PreOp l (QVarOp _ (UnQual _ (Symbol _ "!"))) e -> do checkEnabled BangPatterns p <- checkPat e [] return $ PBangPat l p e -> patFail $ prettyPrint e checkPat e _ = patFail $ prettyPrint e splitBang :: PExp L -> [PExp L] -> (PExp L, [PExp L]) splitBang (App _ f x) es = splitBang f (x:es) splitBang e es = (e, es) checkPatField :: PFieldUpdate L -> P (PatField L) checkPatField (FieldUpdate l n e) = do p <- checkPat e [] return (PFieldPat l n p) checkPatField (FieldPun l n) = return (PFieldPun l n) checkPatField (FieldWildcard l) = return (PFieldWildcard l) checkPAttr :: ParseXAttr L -> P (PXAttr L) checkPAttr (XAttr l n v) = do p <- checkPat v [] return $ PXAttr l n p patFail :: String -> P a patFail s = fail $ "Parse error in pattern: " ++ s checkRPattern :: PExp L -> P (RPat L) checkRPattern e = case e of SeqRP l es -> do rps <- mapM checkRPattern es return $ RPSeq l rps PostOp l e op -> do rpop <- checkRPatOp op rp <- checkRPattern e return $ RPOp l rp rpop GuardRP l e gs -> do rp <- checkPattern e return $ RPGuard l rp gs EitherRP l e1 e2 -> do rp1 <- checkRPattern e1 rp2 <- checkRPattern e2 return $ RPEither l rp1 rp2 CAsRP l n e -> do rp <- checkRPattern e return $ RPCAs l n rp AsPat l n e -> do rp <- checkRPattern e return $ RPAs l n rp Paren l e -> do rp <- checkRPattern e return $ RPParen l rp _ -> do p <- checkPattern e return $ RPPat (ann p) p checkRPatOp :: QOp L -> P (RPatOp L) checkRPatOp o@(QVarOp l (UnQual _ (Symbol _ sym))) = case sym of "*" -> return $ RPStar l "*!" -> return $ RPStarG l "+" -> return $ RPPlus l "+!" -> return $ RPPlusG l "?" -> return $ RPOpt l "?!" -> return $ RPOptG l _ -> rpOpFail o checkRPatOp o = rpOpFail o rpOpFail sym = fail $ "Unrecognized regular pattern operator: " ++ prettyPrint sym fixRPOpPrec :: RPat L -> RPat L fixRPOpPrec rp = case rp of RPOp l rp rpop -> fPrecOp rp (flip (RPOp l) rpop) RPEither l rp1 rp2 -> RPEither l (fixRPOpPrec rp1) (fixRPOpPrec rp2) RPSeq l rps -> RPSeq l $ map fixRPOpPrec rps RPCAs l n rp -> RPCAs l n $ fixRPOpPrec rp RPAs l n rp -> RPAs l n $ fixRPOpPrec rp RPParen l rp -> RPParen l $ fixRPOpPrec rp _ -> rp where fPrecOp :: RPat L -> (RPat L -> RPat L) -> RPat L fPrecOp (RPOp l rp rpop) f = fPrecOp rp (f . flip (RPOp l) rpop) fPrecOp (RPCAs l n rp) f = fPrecAs rp f (RPCAs l n) fPrecOp (RPAs l n rp) f = fPrecAs rp f (RPAs l n) fPrecOp rp f = f $ fixRPOpPrec rp fPrecAs :: RPat L -> (RPat L -> RPat L) -> (RPat L -> RPat L) -> RPat L fPrecAs (RPCAs l n rp) f g = fPrecAs rp f (g . RPCAs l n) fPrecAs (RPAs l n rp) f g = fPrecAs rp f (g . RPAs l n) fPrecAs rp f g = g . f $ fixRPOpPrec rp mkChildrenPat :: [Pat L] -> [Pat L] mkChildrenPat ps = mkCPAux ps [] where mkCPAux :: [Pat L] -> [Pat L] -> [Pat L] mkCPAux [] qs = reverse qs mkCPAux (p:ps) qs = case p of (PRPat l rps) -> [mkCRP l ps (reverse rps ++ map (\q -> RPPat (ann q) q) qs)] _ -> mkCPAux ps (p:qs) mkCRP :: L -> [Pat L] -> [RPat L] -> Pat L mkCRP l [] rps = PXRPats l $ reverse rps mkCRP _ (p:ps) rps = case p of (PXRPats l rqs) -> mkCRP l ps (reverse rqs ++ rps) _ -> mkCRP (ann p) ps (RPPat (ann p) p : rps) ----------------------------------------------------------------------------- -- Check Expression Syntax checkExpr :: PExp L -> P (S.Exp L) checkExpr e = case e of Var l v -> return $ S.Var l v IPVar l v -> return $ S.IPVar l v Con l c -> return $ S.Con l c Lit l lit -> return $ S.Lit l lit InfixApp l e1 op e2 -> check2Exprs e1 e2 (flip (S.InfixApp l) op) App l e1 e2 -> check2Exprs e1 e2 (S.App l) NegApp l e -> check1Expr e (S.NegApp l) Lambda loc ps e -> check1Expr e (S.Lambda loc ps) Let l bs e -> check1Expr e (S.Let l bs) If l e1 e2 e3 -> check3Exprs e1 e2 e3 (S.If l) Case l e alts -> do e <- checkExpr e return (S.Case l e alts) Do l stmts -> checkDo stmts >> return (S.Do l stmts) MDo l stmts -> checkDo stmts >> return (S.MDo l stmts) TupleSection l mes -> if not (any ((==) Nothing) mes) then checkManyExprs (map fromJust mes) (S.Tuple l) else do checkEnabled TupleSections mes' <- mapM mCheckExpr mes return $ S.TupleSection l mes' List l es -> checkManyExprs es (S.List l) -- Since we don't parse things as left or right sections, we need to mangle them into that. Paren l e -> case e of PostOp _ e1 op -> check1Expr e1 (flip (S.LeftSection l) op) PreOp _ op e2 -> check1Expr e2 (S.RightSection l op) _ -> check1Expr e (S.Paren l) RecConstr l c fields -> do fields <- mapM checkField fields return (S.RecConstr l c fields) RecUpdate l e fields -> do fields <- mapM checkField fields e <- checkExpr e return (S.RecUpdate l e fields) EnumFrom l e -> check1Expr e (S.EnumFrom l) EnumFromTo l e1 e2 -> check2Exprs e1 e2 (S.EnumFromTo l) EnumFromThen l e1 e2 -> check2Exprs e1 e2 (S.EnumFromThen l) EnumFromThenTo l e1 e2 e3 -> check3Exprs e1 e2 e3 (S.EnumFromThenTo l) -- a parallel list comprehension, which could be just a simple one ParComp l e qualss -> do e <- checkExpr e case qualss of [quals] -> return (S.ListComp l e quals) _ -> return (S.ParComp l e qualss) ExpTypeSig loc e ty -> do e <- checkExpr e return (S.ExpTypeSig loc e ty) --Template Haskell BracketExp l e -> return $ S.BracketExp l e SpliceExp l e -> return $ S.SpliceExp l e TypQuote l q -> return $ S.TypQuote l q VarQuote l q -> return $ S.VarQuote l q QuasiQuote l n q -> return $ S.QuasiQuote l n q -- Hsx XTag l n attrs mattr cs -> do attrs <- mapM checkAttr attrs cs <- mapM checkExpr cs mattr <- maybe (return Nothing) (\e -> checkExpr e >>= return . Just) mattr return $ S.XTag l n attrs mattr cs XETag l n attrs mattr -> do attrs <- mapM checkAttr attrs mattr <- maybe (return Nothing) (\e -> checkExpr e >>= return . Just) mattr return $ S.XETag l n attrs mattr XPcdata l p -> return $ S.XPcdata l p XExpTag l e -> do e <- checkExpr e return $ S.XExpTag l e -- Pragmas CorePragma l s e -> check1Expr e (S.CorePragma l s) SCCPragma l s e -> check1Expr e (S.SCCPragma l s) GenPragma l s xx yy e -> check1Expr e (S.GenPragma l s xx yy) -- UnknownExpPragma n s -> return $ S.UnknownExpPragma n s -- Arrows Proc l p e -> do e <- checkExpr e return $ S.Proc l p e LeftArrApp l e1 e2 -> check2Exprs e1 e2 (S.LeftArrApp l) RightArrApp l e1 e2 -> check2Exprs e1 e2 (S.RightArrApp l) LeftArrHighApp l e1 e2 -> check2Exprs e1 e2 (S.LeftArrHighApp l) RightArrHighApp l e1 e2 -> check2Exprs e1 e2 (S.RightArrHighApp l) _ -> fail $ "Parse error in expression: " ++ prettyPrint e checkAttr :: ParseXAttr L -> P (S.XAttr L) checkAttr (XAttr l n v) = do v <- checkExpr v return $ S.XAttr l n v checkDo [] = fail "Parse error: Last statement in a do-block must be an expression" checkDo [Qualifier _ _] = return () checkDo (_:xs) = checkDo xs -- type signature for polymorphic recursion!! check1Expr :: PExp L -> (S.Exp L -> a) -> P a check1Expr e1 f = do e1 <- checkExpr e1 return (f e1) check2Exprs :: PExp L -> PExp L -> (S.Exp L -> S.Exp L -> a) -> P a check2Exprs e1 e2 f = do e1 <- checkExpr e1 e2 <- checkExpr e2 return (f e1 e2) check3Exprs :: PExp L -> PExp L -> PExp L -> (S.Exp L -> S.Exp L -> S.Exp L -> a) -> P a check3Exprs e1 e2 e3 f = do e1 <- checkExpr e1 e2 <- checkExpr e2 e3 <- checkExpr e3 return (f e1 e2 e3) checkManyExprs :: [PExp L] -> ([S.Exp L] -> a) -> P a checkManyExprs es f = do es <- mapM checkExpr es return (f es) mCheckExpr :: Maybe (PExp L) -> P (Maybe (S.Exp L)) mCheckExpr Nothing = return Nothing mCheckExpr (Just e) = checkExpr e >>= return . Just checkRuleExpr :: PExp L -> P (S.Exp L) checkRuleExpr = checkExpr readTool :: Maybe String -> Maybe Tool readTool = fmap readC where readC str = case str of "GHC" -> GHC "HUGS" -> HUGS "NHC98" -> NHC98 "YHC" -> YHC "HADDOCK" -> HADDOCK _ -> UnknownTool str checkField :: PFieldUpdate L -> P (S.FieldUpdate L) checkField (FieldUpdate l n e) = check1Expr e (S.FieldUpdate l n) checkField (FieldPun l n) = return $ S.FieldPun l n checkField (FieldWildcard l) = return $ S.FieldWildcard l getGConName :: S.Exp L -> P (QName L) getGConName (S.Con _ n) = return n getGConName (S.List l []) = return (list_cons_name l) getGConName _ = fail "Expression in reification is not a name" ----------------------------------------------------------------------------- -- Check Equation Syntax checkValDef :: L -> PExp L -> Maybe (S.Type L) -> Rhs L -> Maybe (Binds L) -> P (Decl L) checkValDef l lhs optsig rhs whereBinds = do mlhs <- isFunLhs lhs [] case mlhs of Just (f,es,b) -> do ps <- mapM checkPattern es case optsig of -- only pattern bindings can have signatures Nothing -> return (FunBind l $ if b then [Match l f ps rhs whereBinds] else let [a,b] = ps in [InfixMatch l a f b rhs whereBinds]) Just _ -> fail "Cannot give an explicit type signature to a function binding" Nothing -> do lhs <- checkPattern lhs return (PatBind l lhs optsig rhs whereBinds) -- A variable binding is parsed as a PatBind. isFunLhs :: PExp L -> [PExp L] -> P (Maybe (Name L, [PExp L], Bool)) isFunLhs (InfixApp _ l (QVarOp loc (UnQual _ op)) r) es | op =~= (Symbol () "!") = do exts <- getExtensions if BangPatterns `elem` exts then let (b,bs) = splitBang r [] in isFunLhs l (BangPat loc b : bs ++ es) else return $ Just (op, l:r:es, False) -- It's actually a definition of the operator ! | otherwise = return $ Just (op, l:r:es, False) isFunLhs (App _ (Var _ (UnQual _ f)) e) es = return $ Just (f, e:es, True) isFunLhs (App _ f e) es = isFunLhs f (e:es) isFunLhs (Var _ (UnQual _ f)) es@(_:_) = return $ Just (f, es, True) isFunLhs (Paren _ f) es@(_:_) = isFunLhs f es isFunLhs _ _ = return Nothing -- Separating between signature declarations and value definitions in -- a post-processing step checkSigVar :: PExp L -> P (Name L) checkSigVar (Var _ (UnQual _ n)) = return n checkSigVar e = fail $ "Left-hand side of type signature is not a variable: " ++ prettyPrint e ----------------------------------------------------------------------------- -- In a class or instance body, a pattern binding must be of a variable. checkClassBody :: [ClassDecl L] -> P [ClassDecl L] checkClassBody decls = do mapM_ checkClassMethodDef decls return decls where checkClassMethodDef (ClsDecl _ decl) = checkMethodDef decl checkClassMethodDef _ = return () checkInstBody :: [InstDecl L] -> P [InstDecl L] checkInstBody decls = do mapM_ checkInstMethodDef decls return decls where checkInstMethodDef (InsDecl _ decl) = checkMethodDef decl checkInstMethodDef _ = return () checkMethodDef :: Decl L -> P () checkMethodDef (PatBind _ (PVar _ _) _ _ _) = return () checkMethodDef (PatBind loc _ _ _ _) = fail "illegal method definition" -- `atSrcLoc` loc checkMethodDef _ = return () ----------------------------------------------------------------------------- -- Check that an identifier or symbol is unqualified. -- For occasions when doing this in the grammar would cause conflicts. checkUnQual :: QName L -> P (Name L) checkUnQual (Qual _ _ _) = fail "Illegal qualified name" checkUnQual (UnQual _ n) = return n checkUnQual (Special _ _) = fail "Illegal special name" ----------------------------------------------------------------------------- -- Check that two xml tag names are equal -- Could use Eq directly, but I am not sure whether ... -- would be valid, in that case Eq won't work. TODO checkEqNames :: XName L -> XName L -> P (XName L) checkEqNames n@(XName _ n1) (XName _ n2) | n1 == n2 = return n | otherwise = fail "names in matching xml tags are not equal" checkEqNames n@(XDomName _ d1 n1) (XDomName _ d2 n2) | n1 == n2 && d1 == d2 = return n | otherwise = fail "names in matching xml tags are not equal" checkEqNames _ _ = fail "names in matching xml tags are not equal" ----------------------------------------------------------------------------- -- Miscellaneous utilities checkPrec :: Integer -> P Int checkPrec i | 0 <= i && i <= 9 = return (fromInteger i) checkPrec i | otherwise = fail ("Illegal precedence " ++ show i) mkRecConstrOrUpdate :: PExp L -> [PFieldUpdate L] -> P (PExp L) mkRecConstrOrUpdate (Con l c) fs = return (RecConstr l c fs) mkRecConstrOrUpdate e fs@(_:_) = return (RecUpdate (ann e) e fs) mkRecConstrOrUpdate _ _ = fail "Empty record update" ----------------------------------------------------------------------------- -- Reverse a list of declarations, merging adjacent FunBinds of the -- same name and checking that their arities match. checkRevDecls :: [Decl L] -> P [Decl L] checkRevDecls = mergeFunBinds [] where mergeFunBinds revDs [] = return revDs mergeFunBinds revDs (FunBind l ms1@(Match _ name ps _ _:_):ds1) = mergeMatches ms1 ds1 l where arity = length ps mergeMatches ms' (FunBind _ ms@(Match loc name' ps' _ _:_):ds) l | name' =~= name = if length ps' /= arity then fail ("arity mismatch for '" ++ prettyPrint name ++ "'") -- `atSrcLoc` loc else mergeMatches (ms++ms') ds (loc <++> l) mergeMatches ms' ds l = mergeFunBinds (FunBind l ms':revDs) ds mergeFunBinds revDs (FunBind l ims1@(InfixMatch _ _ name _ _ _:_):ds1) = mergeInfix ims1 ds1 l where mergeInfix ims' (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_):ds) l | name' =~= name = mergeInfix (ims++ims') ds (loc <++> l) mergeInfix ms' ds l = mergeFunBinds (FunBind l ms':revDs) ds mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L] checkRevClsDecls = mergeClsFunBinds [] where mergeClsFunBinds revDs [] = return revDs mergeClsFunBinds revDs (ClsDecl l (FunBind _ ms1@(Match _ name ps _ _:_)):ds1) = mergeMatches ms1 ds1 l where arity = length ps mergeMatches ms' (ClsDecl _ (FunBind _ ms@(Match loc name' ps' _ _:_)):ds) l | name' =~= name = if length ps' /= arity then fail ("arity mismatch for '" ++ prettyPrint name ++ "'") -- `atSrcLoc` loc else mergeMatches (ms++ms') ds (loc <++> l) mergeMatches ms' ds l = mergeClsFunBinds (ClsDecl l (FunBind l ms'):revDs) ds mergeClsFunBinds revDs (ClsDecl l (FunBind _ ims1@(InfixMatch _ _ name _ _ _:_)):ds1) = mergeInfix ims1 ds1 l where mergeInfix ims' (ClsDecl _ (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_)):ds) l | name' =~= name = mergeInfix (ims++ims') ds (loc <++> l) mergeInfix ms' ds l = mergeClsFunBinds (ClsDecl l (FunBind l ms'):revDs) ds mergeClsFunBinds revDs (d:ds) = mergeClsFunBinds (d:revDs) ds checkRevInstDecls :: [InstDecl L] -> P [InstDecl L] checkRevInstDecls = mergeInstFunBinds [] where mergeInstFunBinds :: [InstDecl L] -> [InstDecl L] -> P [InstDecl L] mergeInstFunBinds revDs [] = return revDs mergeInstFunBinds revDs (InsDecl l (FunBind _ ms1@(Match _ name ps _ _:_)):ds1) = mergeMatches ms1 ds1 l where arity = length ps mergeMatches ms' (InsDecl _ (FunBind _ ms@(Match loc name' ps' _ _:_)):ds) l | name' =~= name = if length ps' /= arity then fail ("arity mismatch for '" ++ prettyPrint name ++ "'") -- `atSrcLoc` loc else mergeMatches (ms++ms') ds (loc <++> l) mergeMatches ms' ds l = mergeInstFunBinds (InsDecl l (FunBind l ms'):revDs) ds mergeInstFunBinds revDs (InsDecl l (FunBind _ ims1@(InfixMatch _ _ name _ _ _:_)):ds1) = mergeInfix ims1 ds1 l where mergeInfix ims' (InsDecl _ (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_)):ds) l | name' =~= name = mergeInfix (ims++ims') ds (loc <++> l) mergeInfix ms' ds l = mergeInstFunBinds (InsDecl l (FunBind l ms'):revDs) ds mergeInstFunBinds revDs (d:ds) = mergeInstFunBinds (d:revDs) ds ---------------------------------------------------------------- -- Check that newtype declarations have -- the right number (1) of constructors checkDataOrNew :: DataOrNew L -> [a] -> P () checkDataOrNew (NewType _) [x] = return () checkDataOrNew (DataType _) _ = return () checkDataOrNew _ _ = fail "newtype declaration must have exactly one constructor." checkSimpleType :: PType L -> P (DeclHead L) checkSimpleType t = checkSimple "test" t [] --------------------------------------- -- Check actual types checkType :: PType L -> P (S.Type L) checkType t = checkT t False checkT :: PType L -> Bool -> P (S.Type L) checkT t simple = case t of TyForall l tvs@Nothing cs pt -> do when (simple) $ checkEnabled ExplicitForall ctxt <- checkContext cs check1Type pt (S.TyForall l Nothing ctxt) TyForall l tvs cs pt -> do checkEnabled ExplicitForall ctxt <- checkContext cs check1Type pt (S.TyForall l tvs ctxt) TyFun l at rt -> check2Types at rt (S.TyFun l) TyTuple l b pts -> checkTypes pts >>= return . S.TyTuple l b TyList l pt -> check1Type pt (S.TyList l) TyApp l ft at -> check2Types ft at (S.TyApp l) TyVar l n -> return $ S.TyVar l n TyCon l n -> do when (isSymbol n) $ checkEnabled TypeOperators return $ S.TyCon l n TyParen l pt -> check1Type pt (S.TyParen l) -- Here we know that t will be used as an actual type (and not a data constructor) -- so we can check that TypeOperators are enabled. TyInfix l at op bt -> checkEnabled TypeOperators >> check2Types at bt (flip (S.TyInfix l) op) TyKind l pt k -> check1Type pt (flip (S.TyKind l) k) -- TyPred cannot be a valid type _ -> fail $ "Parse error in type: " ++ prettyPrint t check1Type :: PType L -> (S.Type L -> S.Type L) -> P (S.Type L) check1Type pt f = checkT pt True >>= return . f check2Types :: PType L -> PType L -> (S.Type L -> S.Type L -> S.Type L) -> P (S.Type L) check2Types at bt f = checkT at True >>= \a -> checkT bt True >>= \b -> return (f a b) checkTypes :: [PType L] -> P [S.Type L] checkTypes = mapM (flip checkT True) --------------------------------------- -- Converting a complete page checkPageModule :: PExp L -> ([OptionPragma L],[S],L) -> P (Module L) checkPageModule xml (os,ss,inf) = do mod <- getModuleName xml <- checkExpr xml case xml of S.XTag l xn ats mattr cs -> return $ XmlPage (inf<++>l<**(srcInfoPoints l ++ ss)) (ModuleName l mod) os xn ats mattr cs S.XETag l xn ats mattr -> return $ XmlPage (inf<++>l<**(srcInfoPoints l ++ ss)) (ModuleName l mod) os xn ats mattr [] checkHybridModule :: PExp L -> Module L -> S -> S -> P (Module L) checkHybridModule xml (Module inf mh os is ds) s1 s2 = do xml <- checkExpr xml case xml of S.XTag l xn ats mattr cs -> return $ XmlHybrid (inf<++>l<**(s1 : srcInfoPoints inf ++ s2 : srcInfoPoints l)) mh os is ds xn ats mattr cs S.XETag l xn ats mattr -> return $ XmlHybrid (inf<++>l<**(s1 : srcInfoPoints inf ++ s2 : srcInfoPoints l)) mh os is ds xn ats mattr [] {- pageFun :: L -> S.Exp L -> Decl L pageFun loc e = PatBind loc namePat Nothing rhs Nothing where namePat = PVar loc $ Ident loc "page" rhs = UnGuardedRhs (ann e) e mkPage :: Module L -> L -> S.Exp L -> P (Module L) mkPage (Module src mmh os imps decls) loc xml = do let page = pageFun loc xml return $ Module src mmh os imps (decls ++ [page]) mkPageModule :: [OptionPragma L] -> S.Exp L -> P (Module L) mkPageModule os xml = do do loc <- case xml of S.XTag l _ _ _ _ -> return l S.XETag l _ _ _ -> return l _ -> fail "Will not happen since mkPageModule is only called on XML expressions" mod <- getModuleName return $ (Module loc (ModuleName loc mod) os Nothing (Just (ExportSpecList loc [EVar loc $ UnQual loc $ Ident loc "page"])) [] [pageFun loc xml]) -} --------------------------------------- -- Handle dash-identifiers mkDVar :: [String] -> String mkDVar = concat . intersperse "-" --mkDVarExpr :: L -> [String] -> PExp L --mkDVarExpr l = foldl1 (\x y -> InfixApp l x (op $ sym "-") y) . map (Var l . UnQual l . name) --------------------------------------- -- Combine adjacent for-alls. NO! -- -- A valid type must have one for-all at the top of the type, or of the fn arg types mkTyForall :: L -> Maybe [TyVarBind L] -> Maybe (PContext L) -> PType L -> PType L --mkTyForall l mtvs (PContext _ []) ty = mk_forall_ty l mtvs ty mkTyForall l mtvs ctxt ty = TyForall l mtvs ctxt ty {-- mk_forall_ty makes a pure for-all type (no context) mk_forall_ty l (Just []) ty = ty -- Explicit for-all with no tyvars mk_forall_ty l mtvs1 (TyForall _ mtvs2 ctxt ty) = mkTyForall l (mtvs1 `plus` mtvs2) ctxt ty mk_forall_ty l mtvs1 ty = TyForall l mtvs1 (PContext l []) ty mtvs1 `plus` Nothing = mtvs1 Nothing `plus` mtvs2 = mtvs2 (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) -} --------------------------------------- {-- Expressions as we parse them (and patters, and regular patterns) data PExp l = Var l (QName l) -- ^ variable | IPVar l (IPName l) -- ^ implicit parameter variable | Con l (QName l) -- ^ data constructor | Lit l (Literal l) -- ^ literal constant | InfixApp l (PExp l) (QOp l) (PExp l) -- ^ infix application | App l (PExp l) (PExp l) -- ^ ordinary application | NegApp l (PExp l) -- ^ negation expression @-@ /exp/ | Lambda l [Pat l] (PExp l) -- ^ lambda expression | Let l (Binds l) (PExp l) -- ^ local declarations with @let@ | If l (PExp l) (PExp l) (PExp l) -- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/ | Case l (PExp l) [Alt l] -- ^ @case@ /exp/ @of@ /alts/ | Do l [Stmt l] -- ^ @do@-expression: -- the last statement in the list -- should be an expression. | MDo l [Stmt l] -- ^ @mdo@-expression -- | Tuple [PExp] -- ^ tuple expression | TupleSection l [Maybe (PExp l)] -- ^ tuple section expression, e.g. @(,,3)@ | List l [PExp l] -- ^ list expression | Paren l (PExp l) -- ^ parenthesized expression -- RightSection QOp PExp -- ^ right section @(@/qop/ /exp/@)@ | RecConstr l (QName l) [PFieldUpdate l] -- ^ record construction expression | RecUpdate l (PExp l) [PFieldUpdate l] -- ^ record update expression | EnumFrom l (PExp l) -- ^ unbounded arithmetic sequence, -- incrementing by 1 | EnumFromTo l (PExp l) (PExp l) -- ^ bounded arithmetic sequence, -- incrementing by 1 | EnumFromThen l (PExp l) (PExp l) -- ^ unbounded arithmetic sequence, -- with first two elements given | EnumFromThenTo l (PExp l) (PExp l) (PExp l) -- ^ bounded arithmetic sequence, -- with first two elements given | ParComp l (PExp l) [[QualStmt l]] -- ^ parallel list comprehension | ExpTypeSig l (PExp l) (S.Type l) -- ^ expression type signature | AsPat l (Name l) (PExp l) -- ^ patterns only | WildCard l -- ^ patterns only | IrrPat l (PExp l) -- ^ patterns only -- Post-ops for parsing left sections and regular patterns. Not to be left in the final tree. | PostOp l (PExp l) (QOp l) -- ^ post-ops | PreOp l (QOp l) (PExp l) -- ^ pre-ops -- View patterns | ViewPat l (PExp l) (PExp l) -- ^ patterns only -- HaRP | SeqRP l [PExp l] -- ^ regular patterns only | GuardRP l (PExp l) [Stmt l] -- ^ regular patterns only | EitherRP l (PExp l) (PExp l) -- ^ regular patterns only | CAsRP l (Name l) (PExp l) -- ^ regular patterns only -- Template Haskell | VarQuote l (QName l) -- ^ 'x | TypQuote l (QName l) -- ^ ''T | BracketExp l (Bracket l) | SpliceExp l (Splice l) | QuasiQuote l String String -- ^ [$...|...] -- Hsx | XTag l (XName l) [ParseXAttr l] (Maybe (PExp l)) [PExp l] | XETag l (XName l) [ParseXAttr l] (Maybe (PExp l)) | XPcdata l String | XExpTag l (PExp l) | XRPats l [PExp l] -- Pragmas | CorePragma l String (PExp l) | SCCPragma l String (PExp l) | GenPragma l String (Int, Int) (Int, Int) (PExp l) -- | UnknownExpPragma String String -- Generics | ExplTypeArg l (QName l) (S.Type l) -- ^ f {| Int |} x = ... -- Bang Patterns | BangPat l (PExp l) -- ^ f !a = ... -- Arrows | Proc l (Pat l) (PExp l) | LeftArrApp l (PExp l) (PExp l) | RightArrApp l (PExp l) (PExp l) | LeftArrHighApp l (PExp l) (PExp l) | RightArrHighApp l (PExp l) (PExp l) deriving (Eq,Show) data PFieldUpdate l = FieldUpdate l (QName l) (PExp l) | FieldPun l (Name l) | FieldWildcard l deriving (Eq,Show) data ParseXAttr l = XAttr l (XName l) (PExp l) deriving (Eq,Show) instance Annotated PExp where ann e = case e of Var l qn -> l IPVar l ipn -> l Con l qn -> l Lit l lit -> l InfixApp l e1 qop e2 -> l App l e1 e2 -> l NegApp l e -> l Lambda l ps e -> l Let l bs e -> l If l ec et ee -> l Case l e alts -> l Do l ss -> l MDo l ss -> l TupleSection l mes -> l List l es -> l Paren l e -> l RecConstr l qn fups -> l RecUpdate l e fups -> l EnumFrom l e -> l EnumFromTo l ef et -> l EnumFromThen l ef et -> l EnumFromThenTo l ef eth eto -> l ParComp l e qsss -> l ExpTypeSig l e t -> l AsPat l n e -> l WildCard l -> l IrrPat l e -> l PostOp l e op -> l PreOp l op e -> l ViewPat l e1 e2 -> l SeqRP l es -> l GuardRP l e ss -> l EitherRP l e1 e2 -> l CAsRP l n e -> l VarQuote l qn -> l TypQuote l qn -> l BracketExp l br -> l SpliceExp l sp -> l QuasiQuote l sn se -> l XTag l xn xas me es -> l XETag l xn xas me -> l XPcdata l s -> l XExpTag l e -> l XRPats l es -> l CorePragma l s e -> l SCCPragma l s e -> l GenPragma l s n12 n34 e -> l ExplTypeArg l qn t -> l BangPat l e -> l Proc l p e -> l LeftArrApp l e1 e2 -> l RightArrApp l e1 e2 -> l LeftArrHighApp l e1 e2 -> l RightArrHighApp l e1 e2 -> l amap f e = case e of Var l qn -> Var (f l) qn IPVar l ipn -> IPVar (f l) ipn Con l qn -> Con (f l) qn Lit l lit -> Lit (f l) lit InfixApp l e1 qop e2 -> InfixApp (f l) e1 qop e2 App l e1 e2 -> App (f l) e1 e2 NegApp l e -> NegApp (f l) e Lambda l ps e -> Lambda (f l) ps e Let l bs e -> Let (f l) bs e If l ec et ee -> If (f l) ec et ee Case l e alts -> Case (f l) e alts Do l ss -> Do (f l) ss MDo l ss -> MDo (f l) ss TupleSection l mes -> TupleSection (f l) mes List l es -> List (f l) es Paren l e -> Paren (f l) e RecConstr l qn fups -> RecConstr (f l) qn fups RecUpdate l e fups -> RecUpdate (f l) e fups EnumFrom l e -> EnumFrom (f l) e EnumFromTo l ef et -> EnumFromTo (f l) ef et EnumFromThen l ef et -> EnumFromThen (f l) ef et EnumFromThenTo l ef eth eto -> EnumFromThenTo (f l) ef eth eto ParComp l e qsss -> ParComp (f l) e qsss ExpTypeSig l e t -> ExpTypeSig (f l) e t AsPat l n e -> AsPat (f l) n e WildCard l -> WildCard (f l) IrrPat l e -> IrrPat (f l) e PostOp l e op -> PostOp (f l) e op PreOp l op e -> PreOp (f l) op e ViewPat l e1 e2 -> ViewPat (f l) e1 e2 SeqRP l es -> SeqRP (f l) es GuardRP l e ss -> GuardRP (f l) e ss EitherRP l e1 e2 -> EitherRP (f l) e1 e2 CAsRP l n e -> CAsRP (f l) n e ExplTypeArg l n t -> ExplTypeArg (f l) n t BangPat l e -> BangPat (f l) e VarQuote l qn -> VarQuote (f l) qn TypQuote l qn -> TypQuote (f l) qn BracketExp l br -> BracketExp (f l) br SpliceExp l sp -> SpliceExp (f l) sp QuasiQuote l sn se -> QuasiQuote (f l) sn se XTag l xn xas me es -> XTag (f l) xn xas me es XETag l xn xas me -> XETag (f l) xn xas me XPcdata l s -> XPcdata (f l) s XExpTag l e -> XExpTag (f l) e CorePragma l s e -> CorePragma (f l) s e SCCPragma l s e -> SCCPragma (f l) s e GenPragma l s n12 n34 e -> GenPragma (f l) s n12 n34 e Proc l p e -> Proc (f l) p e LeftArrApp l e1 e2 -> LeftArrApp (f l) e1 e2 RightArrApp l e1 e2 -> RightArrApp (f l) e1 e2 LeftArrHighApp l e1 e2 -> LeftArrHighApp (f l) e1 e2 RightArrHighApp l e1 e2 -> RightArrHighApp (f l) e1 e2 instance Functor PExp where fmap f e = case e of Var l qn -> Var (f l) (fmap f qn) IPVar l ipn -> IPVar (f l) (fmap f ipn) Con l qn -> Con (f l) (fmap f qn) Lit l lit -> Lit (f l) (fmap f lit) InfixApp l e1 qop e2 -> InfixApp (f l) (fmap f e1) (fmap f qop) (fmap f e2) App l e1 e2 -> App (f l) (fmap f e1) (fmap f e2) NegApp l e -> NegApp (f l) (fmap f e) Lambda l ps e -> Lambda (f l) (map (fmap f) ps) (fmap f e) Let l bs e -> Let (f l) (fmap f bs) (fmap f e) If l ec et ee -> If (f l) (fmap f ec) (fmap f et) (fmap f ee) Case l e alts -> Case (f l) (fmap f e) (map (fmap f) alts) Do l ss -> Do (f l) (map (fmap f) ss) MDo l ss -> MDo (f l) (map (fmap f) ss) TupleSection l mes -> TupleSection (f l) (map (fmap (fmap f)) mes) List l es -> List (f l) (map (fmap f) es) Paren l e -> Paren (f l) (fmap f e) RecConstr l qn fups -> RecConstr (f l) (fmap f qn) (map (fmap f) fups) RecUpdate l e fups -> RecUpdate (f l) (fmap f e) (map (fmap f) fups) EnumFrom l e -> EnumFrom (f l) (fmap f e) EnumFromTo l ef et -> EnumFromTo (f l) (fmap f ef) (fmap f et) EnumFromThen l ef et -> EnumFromThen (f l) (fmap f ef) (fmap f et) EnumFromThenTo l ef eth eto -> EnumFromThenTo (f l) (fmap f ef) (fmap f eth) (fmap f eto) ParComp l e qsss -> ParComp (f l) (fmap f e) (map (map (fmap f)) qsss) ExpTypeSig l e t -> ExpTypeSig (f l) (fmap f e) (fmap f t) AsPat l n e -> AsPat (f l) (fmap f n) (fmap f e) WildCard l -> WildCard (f l) IrrPat l e -> IrrPat (f l) (fmap f e) PostOp l e op -> PostOp (f l) (fmap f e) (fmap f op) PreOp l op e -> PreOp (f l) (fmap f op) (fmap f e) ViewPat l e1 e2 -> ViewPat (f l) (fmap f e1) (fmap f e2) SeqRP l es -> SeqRP (f l) (map (fmap f) es) GuardRP l e ss -> GuardRP (f l) (fmap f e) (map (fmap f) ss) EitherRP l e1 e2 -> EitherRP (f l) (fmap f e1) (fmap f e2) CAsRP l n e -> CAsRP (f l) (fmap f n) (fmap f e) ExplTypeArg l n t -> ExplTypeArg (f l) (fmap f n) (fmap f t) BangPat l e -> BangPat (f l) (fmap f e) VarQuote l qn -> VarQuote (f l) (fmap f qn) TypQuote l qn -> TypQuote (f l) (fmap f qn) BracketExp l br -> BracketExp (f l) (fmap f br) SpliceExp l sp -> SpliceExp (f l) (fmap f sp) QuasiQuote l sn se -> QuasiQuote (f l) sn se XTag l xn xas me es -> XTag (f l) (fmap f xn) (map (fmap f) xas) (fmap (fmap f) me) (map (fmap f) es) XETag l xn xas me -> XETag (f l) (fmap f xn) (map (fmap f) xas) (fmap (fmap f) me) XPcdata l s -> XPcdata (f l) s XExpTag l e -> XExpTag (f l) (fmap f e) CorePragma l s e -> CorePragma (f l) s (fmap f e) SCCPragma l s e -> SCCPragma (f l) s (fmap f e) GenPragma l s n12 n34 e -> GenPragma (f l) s n12 n34 (fmap f e) Proc l p e -> Proc (f l) (fmap f p) (fmap f e) LeftArrApp l e1 e2 -> LeftArrApp (f l) (fmap f e1) (fmap f e2) RightArrApp l e1 e2 -> RightArrApp (f l) (fmap f e1) (fmap f e2) LeftArrHighApp l e1 e2 -> LeftArrHighApp (f l) (fmap f e1) (fmap f e2) RightArrHighApp l e1 e2 -> RightArrHighApp (f l) (fmap f e1) (fmap f e2) instance Functor PFieldUpdate where fmap f (FieldUpdate l qn e) = FieldUpdate (f l) (fmap f qn) (fmap f e) fmap f (FieldPun l n) = FieldPun (f l) (fmap f n) fmap f (FieldWildcard l) = FieldWildcard (f l) instance Annotated PFieldUpdate where ann (FieldUpdate l qn e) = l ann (FieldPun l n) = l ann (FieldWildcard l) = l amap f (FieldUpdate l qn e) = FieldUpdate (f l) qn e amap f (FieldPun l n) = FieldPun (f l) n amap f (FieldWildcard l) = FieldWildcard (f l) instance Functor ParseXAttr where fmap f (XAttr l xn e) = XAttr (f l) (fmap f xn) (fmap f e) instance Annotated ParseXAttr where ann (XAttr l _ _) = l amap f (XAttr l xn e) = XAttr (f l) xn e p_unit_con :: l -> PExp l p_unit_con l = Con l (unit_con_name l) p_tuple_con :: l -> Boxed -> Int -> PExp l p_tuple_con l b i = Con l (tuple_con_name l b i) p_unboxed_singleton_con :: l -> PExp l p_unboxed_singleton_con l = Con l (unboxed_singleton_con_name l) data PContext l = CxSingle l (PAsst l) | CxTuple l [PAsst l] | CxParen l (PContext l) | CxEmpty l deriving (Eq, Show) instance Functor PContext where fmap f (CxSingle l asst) = CxSingle (f l) (fmap f asst) fmap f (CxTuple l assts) = CxTuple (f l) (map (fmap f) assts) fmap f (CxParen l ctxt) = CxParen (f l) (fmap f ctxt) fmap f (CxEmpty l) = CxEmpty (f l) instance Annotated PContext where ann (CxSingle l asst ) = l ann (CxTuple l assts) = l ann (CxParen l ctxt ) = l ann (CxEmpty l) = l amap f (CxSingle l asst ) = CxSingle (f l) asst amap f (CxTuple l assts) = CxTuple (f l) assts amap f (CxParen l ctxt ) = CxParen (f l) ctxt amap f (CxEmpty l) = CxEmpty (f l) data PType l = TyForall l (Maybe [TyVarBind l]) (Maybe (PContext l)) (PType l) | TyFun l (PType l) (PType l) -- ^ function type | TyTuple l Boxed [PType l] -- ^ tuple type, possibly boxed | TyList l (PType l) -- ^ list syntax, e.g. [a], as opposed to [] a | TyApp l (PType l) (PType l) -- ^ application of a type constructor | TyVar l (Name l) -- ^ type variable | TyCon l (QName l) -- ^ named type or type constructor | TyParen l (PType l) -- ^ type surrounded by parentheses | TyPred l (PAsst l) -- ^ assertion of an implicit parameter | TyInfix l (PType l) (QName l) (PType l) -- ^ infix type constructor | TyKind l (PType l) (Kind l) -- ^ type with explicit kind signature deriving (Eq, Show) instance Functor PType where fmap f t = case t of TyForall l mtvs mcx t -> TyForall (f l) (fmap (map (fmap f)) mtvs) (fmap (fmap f) mcx) (fmap f t) TyFun l t1 t2 -> TyFun (f l) (fmap f t1) (fmap f t2) TyTuple l b ts -> TyTuple (f l) b (map (fmap f) ts) TyList l t -> TyList (f l) (fmap f t) TyApp l t1 t2 -> TyApp (f l) (fmap f t1) (fmap f t2) TyVar l n -> TyVar (f l) (fmap f n) TyCon l qn -> TyCon (f l) (fmap f qn) TyParen l t -> TyParen (f l) (fmap f t) TyPred l asst -> TyPred (f l) (fmap f asst) TyInfix l ta qn tb -> TyInfix (f l) (fmap f ta) (fmap f qn) (fmap f tb) TyKind l t k -> TyKind (f l) (fmap f t) (fmap f k) instance Annotated PType where ann t = case t of TyForall l mtvs cx t -> l TyFun l t1 t2 -> l TyTuple l b ts -> l TyList l t -> l TyApp l t1 t2 -> l TyVar l n -> l TyCon l qn -> l TyParen l t -> l TyInfix l ta qn tb -> l TyKind l t k -> l amap f t = case t of TyForall l mtvs mcx t -> TyForall (f l) mtvs mcx t TyFun l t1 t2 -> TyFun (f l) t1 t2 TyTuple l b ts -> TyTuple (f l) b ts TyList l t -> TyList (f l) t TyApp l t1 t2 -> TyApp (f l) t1 t2 TyVar l n -> TyVar (f l) n TyCon l qn -> TyCon (f l) qn TyParen l t -> TyParen (f l) t TyInfix l ta qn tb -> TyInfix (f l) ta qn tb TyKind l t k -> TyKind (f l) t k data PAsst l = ClassA l (QName l) [PType l] | InfixA l (PType l) (QName l) (PType l) | IParam l (IPName l) (PType l) | EqualP l (PType l) (PType l) deriving (Eq, Show) instance Functor PAsst where fmap f asst = case asst of ClassA l qn ts -> ClassA (f l) (fmap f qn) (map (fmap f) ts) InfixA l ta qn tb -> InfixA (f l) (fmap f ta) (fmap f qn) (fmap f tb) IParam l ipn t -> IParam (f l) (fmap f ipn) (fmap f t) EqualP l t1 t2 -> EqualP (f l) (fmap f t1) (fmap f t2) instance Annotated PAsst where ann asst = case asst of ClassA l qn ts -> l InfixA l ta qn tb -> l IParam l ipn t -> l EqualP l t1 t2 -> l amap f asst = case asst of ClassA l qn ts -> ClassA (f l) qn ts InfixA l ta qn tb -> InfixA (f l) ta qn tb IParam l ipn t -> IParam (f l) ipn t EqualP l t1 t2 -> EqualP (f l) t1 t2 unit_tycon, fun_tycon, list_tycon, unboxed_singleton_tycon :: l -> PType l unit_tycon l = TyCon l (unit_tycon_name l) fun_tycon l = TyCon l (fun_tycon_name l) list_tycon l = TyCon l (list_tycon_name l) unboxed_singleton_tycon l = TyCon l (unboxed_singleton_tycon_name l) tuple_tycon :: l -> Boxed -> Int -> PType l tuple_tycon l b i = TyCon l (tuple_tycon_name l b i) -}