packages feed

arrowp-qq (empty) → 0.1

raw patch · 11 files changed

+2539/−0 lines, 11 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, haskell-src, template-haskell, transformers

Files

+ LICENCE view
@@ -0,0 +1,5 @@+LICENSE++ArrSyn and ArrCode are released under the GNU General Public License.+The rest is licenced under the BSD-style license of the base package+in the Haskell hierarchical libraries.
+ README view
@@ -0,0 +1,15 @@+A prototype quasiquoter for arrow notation packaged by Jose Iborra,+based on the arrowp preprocessor developed by Ross Paterson <ross@soi.city.ac.uk>.++Note that recent versions of GHC support this notation directly, and+give better error messages to boot. But the translation produced by GHC+is in some cases not as good as it could be.++RUNNING THE ARROW QUASI QUOTER+++addA :: Arrow a => a b Int -> a b Int -> a b Int+addA f g = [proc| x -> do+		y <- f -< x+		z <- g -< x+		returnA -< y + z |]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ arrowp-qq.cabal view
@@ -0,0 +1,24 @@+Name:           arrowp-qq+Version:        0.1+Cabal-Version:  >= 1.20+Build-Type:     Simple+License:        GPL+License-File:   LICENCE+Author:         Jose Iborra <pepeiborra@gmail.com>+Maintainer:     Jose Iborra <pepeiborra@gmail.com>+Homepage:       http://www.haskell.org/arrows/+Category:       Development+Synopsis:       quasiquoter translating arrow notation into Haskell 98+Description:    A quasiquoter built on top of the arrowp package.+Extra-Source-Files: README++Library+    Exposed-Modules:     Control.Arrow.QuasiQuoter+    Build-Depends: base < 5, array, containers, haskell-src, template-haskell < 2.12, transformers+    Hs-Source-Dirs: src+    Other-Modules:  ArrCode ArrSyn Lexer Parser Parser State Utils+    Default-Language:    Haskell2010++Source-Repository head+    Type: darcs+    Location: http://github.com/pepeiborra/arrowp
+ src/ArrCode.lhs view
@@ -0,0 +1,245 @@+> module ArrCode(+>	Arrow,+>	bind, anon,+>	arr, arrLet, (>>>), arrowExp, applyOp, infixOp, (|||), first,+>	VarDecl(VarDecl), letCmd,+>	context, anonArgs, toHaskell,+>	Tuple(..),+>	isEmptyTuple, unionTuple, minusTuple, intersectTuple,+>	patternTuple, expTuple,+>	returnA_exp, arr_exp, compose_op, choice_op, first_exp,+>	left_exp, right_exp, app_exp, loop_exp,+>       ifte+> ) where++> import Utils++> import Data.Set (Set)+> import qualified Data.Set as Set+> import Language.Haskell.Syntax++> data Arrow = Arrow {+>		code :: Code,+>		context :: Tuple, -- named input components used by the arrow+>		anonArgs :: Int   -- number of unnamed arguments+>	}++> data VarDecl a = VarDecl SrcLoc HsName a+>	deriving (Eq,Show)++> instance Functor VarDecl where+>	fmap f (VarDecl loc name a) = VarDecl loc name (f a)++> data Code+>	= ReturnA			-- returnA = arr id+>	| Arr Int HsPat [Binding] HsExp	-- arr (first^n (\p -> ... e))+>	| Compose Code [Code] Code	-- composition of 2 or more elts+>	| Op HsExp [Code]		-- combinator applied to arrows+>	| InfixOp Code HsQOp Code+>	| Let [VarDecl Code] Code+>       | Ifte HsExp Code Code++> data Binding = BindLet [HsDecl] | BindCase HsPat HsExp++-----------------------------------------------------------------------------+Arrow constants++> compose_op, choice_op :: HsQOp+> returnA_exp, arr_exp, first_exp :: HsExp+> left_exp, right_exp, app_exp, loop_exp :: HsExp++> returnA_exp	= HsVar (UnQual (HsIdent "returnA"))+> arr_exp	= HsVar (UnQual (HsIdent "arr"))+> compose_op	= HsQVarOp (UnQual (HsSymbol ">>>"))+> choice_op	= HsQVarOp (UnQual (HsSymbol "|||"))+> first_exp	= HsVar (UnQual (HsIdent "first"))+> left_exp	= HsCon (UnQual (HsIdent "Left"))+> right_exp	= HsCon (UnQual (HsIdent "Right"))+> app_exp	= HsVar (UnQual (HsIdent "app"))+> loop_exp	= HsVar (UnQual (HsIdent "loop"))++-----------------------------------------------------------------------------+Arrow constructors++> bind :: Set HsName -> Arrow -> Arrow+> bind vars a = a {+>		context = context a `minusTuple` vars+>	}++> anon :: Int -> Arrow -> Arrow+> anon anonCount a = a {+>		anonArgs = anonArgs a + anonCount+>	}++> arr :: Int -> Tuple -> HsPat -> HsExp -> Arrow+> arr anons t p e = Arrow {+>		code = if same p e then ReturnA else Arr anons p [] e,+>		context = t `intersectTuple` freeVars e,+>		anonArgs = anons+>	}+>	where	same :: HsPat -> HsExp -> Bool+>		same (HsPApp n1 []) (HsCon n2) = n1 == n2+>		same (HsPVar n1) (HsVar n2) = UnQual n1 == n2+>		same (HsPTuple ps) (HsTuple es) =+>			length ps == length es && and (zipWith same ps es)+>		same (HsPAsPat n p) e = e == HsVar (UnQual n) || same p e+>		same (HsPParen p) e = same p e+>		same p (HsParen e) = same p e+>		same _ _ = False	-- other cases don't arise++> arrLet :: Int -> Tuple -> HsPat -> [HsDecl] -> HsExp -> Arrow+> arrLet anons t p ds e = Arrow {+>		code = Arr anons p [BindLet ds] e,+>		context = t `intersectTuple` vs,+>		anonArgs = anons+>	}+>	where	vs = (freeVars e `Set.union` freeVars ds)+>				`Set.difference` definedVars ds++> ifte :: HsExp -> Arrow -> Arrow -> Arrow+> ifte c th el = Arrow+>             { code = Ifte c (code th) (code el)+>             , context = context th `unionTuple` context el+>             , anonArgs = 0+>             }++> (>>>) :: Arrow -> Arrow -> Arrow+> a1 >>> a2 = a1 { code = compose (code a1) (code a2) }++> arrowExp :: HsExp -> Arrow+> arrowExp e = Arrow {+>		code = if e == returnA_exp then ReturnA else Op e [],+>		context = emptyTuple,+>		anonArgs = 0+>	}++> applyOp :: HsExp -> [Arrow] -> Arrow+> applyOp e as = Arrow {+>		code = Op e (map code as),+>		context = foldr unionTuple emptyTuple (map context as),+>		anonArgs = 0	-- BUG: see below+>	}++Setting anonArgs to 0 for infixOp is incorrect, but we can't know the+correct value without types.++> infixOp :: Arrow -> HsQOp -> Arrow -> Arrow+> infixOp a1 op a2 = Arrow {+>		code = InfixOp (code a1) op (code a2),+>		context = context a1 `unionTuple` context a2,+>		anonArgs = 0	-- BUG: as above+>	}++> first :: Arrow -> Tuple -> Arrow+> first a ps = Arrow {+>		code = Op first_exp [code a],+>		context = context a `unionTuple` ps,+>		anonArgs = 0+>	}++> (|||) :: Arrow -> Arrow -> Arrow+> a1 ||| a2 = Arrow {+>		code = InfixOp (code a1) choice_op (code a2),+>		context = context a1 `unionTuple` context a2,+>		anonArgs = 0+>	}++> letCmd :: [VarDecl Arrow] -> Arrow -> Arrow+> letCmd defs a = Arrow {+>		code = Let (map (fmap code) defs) (code a),+>		context = context a,+>		anonArgs = anonArgs a+>	}++Composition, with some simplification++> compose :: Code -> Code -> Code+> compose ReturnA a = a+> compose a ReturnA = a+> compose a1@(Arr n1 p1 ds1 e1) a2@(Arr n2 p2 ds2 e2)+>	| n1 /= n2 = Compose a1 [] a2	-- could do better, but can this arise?+>	| same p2 e1 = Arr n1 p1 (ds1 ++ ds2) e2+>	| otherwise = Arr n1 p1 (ds1 ++ BindCase p2 e1:ds2) e2+>	where	same :: HsPat -> HsExp -> Bool+>		same (HsPApp n1 []) (HsCon n2) = n1 == n2+>		same (HsPVar n1) (HsVar n2) = UnQual n1 == n2+>		same (HsPTuple ps) (HsTuple es) =+>			length ps == length es && and (zipWith same ps es)+>		same (HsPParen p) e = same p e+>		same p (HsParen e) = same p e+>		same _ _ = False	-- other cases don't arise+> compose (Compose f1 as1 g1) (Compose f2 as2 g2) =+>	Compose f1 (as1 ++ (compose g1 f2 : as2)) g2+> compose a (Compose f bs g) =+>	Compose (compose a f) bs g+> compose (Compose f as g) b =+>	Compose f as (compose g b)+> compose a1 a2 =+>	Compose a1 [] a2++-----------------------------------------------------------------------------+Conversion to Haskell++> toHaskell :: Arrow -> HsExp+> toHaskell = toHaskellCode . code++> toHaskellCode :: Code -> HsExp+> toHaskellCode ReturnA =+>	returnA_exp+> toHaskellCode (Arr n p bs e) =+>	HsApp arr_exp+>		(times n (HsParen . HsApp first_exp) body)+>	where	body = HsParen (HsLambda undefined [p] (foldr addBinding e bs))+>		addBinding :: Binding -> HsExp -> HsExp+>		addBinding (BindLet ds) e = HsLet ds e+>		addBinding (BindCase p e) e' =+>			HsCase e [HsAlt undefined p (HsUnGuardedAlt e') []]+> toHaskellCode (Compose f as g) =+>	foldr comp (toHaskellArg g) (map toHaskellArg (f:as))+>	where	comp f g = HsInfixApp f compose_op g+> toHaskellCode (Op op as) =+>	foldl HsApp op (map (paren . toHaskellCode) as)+> toHaskellCode (InfixOp a1 op a2) =+>	HsInfixApp (toHaskellArg a1) op (toHaskellArg a2)+> toHaskellCode (Let nas a) =+>	HsLet (map toHaskellDecl nas) (toHaskellCode a)+>	where	toHaskellDecl (VarDecl loc n a) =+>			HsPatBind loc (HsPVar n)+>				(HsUnGuardedRhs (toHaskellCode a)) []+> toHaskellCode (Ifte cond th el) = HsIf cond (toHaskellCode th) (toHaskellCode el)++> toHaskellArg :: Code -> HsExp+> toHaskellArg a = parenInfixArg (toHaskellCode a)++-----------------------------------------------------------------------------+Tuples, representing sets of variables.++> newtype Tuple = Tuple (Set HsName)++Tuple extractors, including matching expression and pattern.++> isEmptyTuple :: Tuple -> Bool+> isEmptyTuple (Tuple t) = Set.null t++> patternTuple :: Tuple -> HsPat+> patternTuple (Tuple t) = tupleP (map HsPVar (Set.toList t))++> expTuple :: Tuple -> HsExp+> expTuple (Tuple t) = tuple (map (HsVar . UnQual) (Set.toList t))++Operations on tuples++> emptyTuple :: Tuple+> emptyTuple = Tuple Set.empty++> unionTuple :: Tuple -> Tuple -> Tuple+> unionTuple (Tuple a) (Tuple b) = Tuple (a `Set.union` b)++Remove all usages of a set of variables.++> minusTuple :: Tuple -> Set HsName -> Tuple+> Tuple t `minusTuple` vs = Tuple (t `Set.difference` vs)++> intersectTuple :: Tuple -> Set HsName -> Tuple+> Tuple t `intersectTuple` vs = Tuple (t `Set.intersection` vs)+
+ src/ArrSyn.lhs view
@@ -0,0 +1,304 @@+Additional abstract syntax for arrow expressions++> module ArrSyn(+>	Cmd(..),+>	Stmts, Stmt(..), CmdDecl, VarDecl(..),+>	Alt(..), GuardedAlts(..), GuardedAlt(..),+>	translate	-- :: HsPat -> Cmd -> HsExp+> ) where++> import ArrCode+> import State		-- Haskell 98 version of Control.Monad.State+> import Utils++> import Data.List(mapAccumL)+> import Data.Map (Map)+> import qualified Data.Map as Map+> import Data.Set (Set)+> import qualified Data.Set as Set+> import Language.Haskell.Syntax++> data Cmd+>	= Input HsExp HsExp+>	| Kappa SrcLoc [HsPat] Cmd+>	| Op HsExp [Cmd]+>	| InfixOp Cmd HsQOp Cmd+>	| Let [HsDecl] Cmd+>	| LetCmd (VarDecl Cmd) Cmd+>	| If HsExp Cmd Cmd+>	| Case HsExp [Alt]+>	| Paren Cmd+>	| Do [Stmt] Cmd+>	| App Cmd HsExp+>	| CmdVar HsName+>   deriving (Eq,Show)++> type CmdDecl = (HsName, Cmd)+> type Stmts = ([Stmt], Cmd)++> data Stmt+>	= Generator SrcLoc HsPat Cmd+>	| RecStmt [Stmt]+>	| LetStmt [HsDecl]+>	| LetCmdStmt (VarDecl Cmd)+>   deriving (Eq,Show)++> data Alt+>	= Alt SrcLoc HsPat GuardedAlts [HsDecl]+>   deriving (Eq,Show)++> data GuardedAlts+>	= UnGuardedAlt Cmd+>	| GuardedAlts [GuardedAlt]+>   deriving (Eq,Show)++> data GuardedAlt+>	= GuardedAlt SrcLoc HsExp Cmd+>   deriving (Eq,Show)++-----------------------------------------------------------------------------+Utilities++> pair :: HsExp -> HsExp -> HsExp+> pair e1 e2 = HsTuple [e1, e2]++Turn redefined variables into wildcards, so the new pattern will be legal.++> pairP :: HsPat -> HsPat -> HsPat+> pairP p1 p2 = HsPTuple [hide p1, p2]+>	where	vs = freeVars p2+>		hide p@(HsPVar n)+>			| n `Set.member` vs = HsPWildCard+>			| otherwise = p+>		hide (HsPNeg p) = HsPNeg (hide p)+>		hide (HsPInfixApp p1 n p2) = HsPInfixApp (hide p1) n (hide p2)+>		hide (HsPApp n ps) = HsPApp n (map hide ps)+>		hide (HsPTuple ps) = HsPTuple (map hide ps)+>		hide (HsPList ps) = HsPList (map hide ps)+>		hide (HsPParen p) = HsPParen (hide p)+>		hide (HsPRec n pfs) = HsPRec n (map hideField pfs)+>			where	hideField (HsPFieldPat f p) =+>					HsPFieldPat f (hide p)+>		hide (HsPAsPat n p)+>			| n `Set.member` vs = hide p+>			| otherwise = HsPAsPat n (hide p)+>		hide (HsPIrrPat p) = HsPIrrPat (hide p)+>		hide p = p++> left, right :: HsExp -> HsExp+> left f = HsApp left_exp (paren f)+> right f = HsApp right_exp (paren f)++> loop :: Arrow -> Arrow+> loop f = applyOp loop_exp [f]++> app, returnA :: Arrow+> app = arrowExp app_exp+> returnA = arrowExp returnA_exp++> returnCmd :: HsExp -> Cmd+> returnCmd = Input returnA_exp++-----------------------------------------------------------------------------+Translation state++> data TransState = TransState {+>	locals :: Set HsName,	-- vars in scope defined in this proc+>	cmdVars :: Map HsName Arrow+> }++> input :: TransState -> Tuple+> input s = Tuple (locals s)++> startPattern :: HsPat -> (TransState, HsPat)+> startPattern p =+>	(TransState {+>		locals = freeVars p,+>		cmdVars = Map.empty+>	 }, p)++> class AddVars a where+>	addVars :: TransState -> a -> (TransState, a)++> instance AddVars a => AddVars [a] where+>	addVars = mapAccumL addVars++> instance AddVars HsPat where+>	addVars s p =+>		(s {locals = locals s `Set.union` freeVars p}, p)+++> instance AddVars HsDecl where+>	addVars s d@(HsFunBind (HsMatch _ n _ _ _:_)) =+>		(s', d)+>		where	(s', _) = addVars s (HsPVar n)+>	addVars s (HsPatBind loc p rhs decls) =+>		(s', HsPatBind loc p' rhs decls)+>		where	(s', p') = addVars s p+>	addVars s d = (s, d)++-----------------------------------------------------------------------------+Translation to Haskell++This is a 2-phase process:+- transCmd generates an abstract arrow combinator language represented+  by the Arrow type, and+- toHaskell turns that into Haskell.++> translate :: HsPat -> Cmd -> HsExp+> translate p c = paren (toHaskell (transCmd s p' c))+>	where	(s, p') = startPattern p++The pattern argument is often pseudo-recursively defined in terms of+the context part of the result of these functions.  (It's not real+recursion, because that part is independent of the pattern.)++> transCmd :: TransState -> HsPat -> Cmd -> Arrow+> transCmd s p (Input f e)+>	| Set.null (freeVars f `Set.intersection` locals s) =+>		arr 0 (input s) p e >>> arrowExp f+>	| otherwise =+>		arr 0 (input s) p (pair f e) >>> app+> transCmd s p (Kappa _ ps c) =+>	anon (length ps) $ bind (freeVars ps) $+>		transCmd s' (foldl pairP p ps') c+>	where	(s', ps') = addVars s ps+> transCmd s p (Op op cs) =+>	applyOp op (map (transCmd s p) cs)+> transCmd s p (InfixOp c1 op c2) =+>	infixOp (transCmd s p c1) op (transCmd s p c2)+> transCmd s p (Let decls c) =+>	arrLet (anonArgs a) (input s) p decls' e >>> a+>	where	(s', decls') = addVars s decls+>		(e, a) = transTrimCmd s' c+> transCmd s p (If e c1 c2)+>   | Set.null (freeVars e `Set.intersection` locals s) =+>       ifte e (transCmd s p c1) (transCmd s p c2)+>   | otherwise =+>	arr 0 (input s) p (HsIf e (left e1) (right e2)) >>> (a1 ||| a2)+>	where	(e1, a1) = transTrimCmd s c1+>		(e2, a2) = transTrimCmd s c2+> transCmd s p (Case e as) =+>	transCase s p e as+> transCmd s p (Paren c) =+>	transCmd s p c+> transCmd s p (Do ss c) =+>	transDo s p ss c+> transCmd s p (App c arg) =+>	anon (-1) $+>	arr (anonArgs a) (input s) p (pair e arg) >>> a+>	where	(e, a) = transTrimCmd s c++The following awful hack is there because if the command is recursively+defined, computation of its context will not terminate.  So we plug in+returnA (empty context) to get an arrow whose code is ignored in the+recomputation of the real arrow for a1.+Mutually recursive bindings will be a bit more tricky.++> transCmd s p (LetCmd (VarDecl loc n c1) c2) =+>	letCmd [VarDecl loc n a1] (transCmd s' p c2)+>	where	(_, a1) = transTrimCmd s' c1+>		s' = s { cmdVars = Map.insert n a0 (cmdVars s) }+>		s0 = s { cmdVars = Map.insert n returnA (cmdVars s) }+>		a0 = transCmd s0 p c1	-- hackety hack+> transCmd s p (CmdVar n) =+>	arr (anonArgs a) (input s) p e >>> arrowExp (HsVar (UnQual n))+>	where	Just a = Map.lookup n (cmdVars s)+>		e = expTuple (context a)++Like TransCmd, but use the minimal input pattern.  The first component+of the result is the matching expression to build this input.+That is, the result is (e, proc p' -> c) with the minimal p' such that++	proc p -> c = arr (first^n (p -> e)) >>> (proc p' -> c)++where n is the number of anonymous arguments taken by c.++> transTrimCmd :: TransState -> Cmd -> (HsExp, Arrow)+> transTrimCmd s c = (expTuple (context a), a)+>	where	a = transCmd s (patternTuple (context a)) c++> transDo :: TransState -> HsPat -> [Stmt] -> Cmd -> Arrow+> transDo s p [] c =+>	transCmd s p c+> transDo s p (Generator _ pg cg:ss) c =+>	if isEmptyTuple u then+>		transCmd s p cg >>> transDo s' pg ss c+>	else+>		arr 0 (input s) p (pair eg (expTuple u)) >>> first ag u >>> a+>	where	(s', pg') = addVars s pg+>		a = bind (freeVars pg)+>			(transDo s' (pairP pg' (patternTuple u)) ss c)+>		u = context a+>		(eg, ag) = transTrimCmd s cg+> transDo s p (LetStmt decls:ss) c =+>	transCmd s p (Let decls (Do ss c))+> transDo s p (RecStmt rss:ss) c =+>	bind defined+>		(loop (transDo s' (pairP p (irrPat (patternTuple feedback)))+>			rss'+>			(returnCmd (pair output (expTuple feedback)))+>		      ) >>> a)+>	where	defined = definedVars rss+>		(s', rss') = addVars s rss+>		(output, a) = transTrimCmd s' (Do ss c)+>		feedback = context (transDo s' p rss'+>				(returnCmd (foldr pair output $ map (HsVar . UnQual) $ Set.toList defined)))+>			`intersectTuple` defined+> transDo s p (LetCmdStmt vdecl:ss) c =+>	transCmd s p (LetCmd vdecl (Do ss c))++The set of variables defined by a list of statements in a rec.++> instance DefinedVars Stmt where+>	definedVars (Generator _ p _) = freeVars p+>	definedVars (LetStmt decls) = definedVars decls+>	definedVars (RecStmt stmts) = definedVars stmts+>	definedVars (LetCmdStmt _vdecl) = Set.empty++> instance AddVars Stmt where+>	addVars s (Generator loc p c) =+>		(s', Generator loc p' c)+>		where	(s', p') = addVars s p+>	addVars s (LetStmt decls) =+>		(s', LetStmt decls')+>		where	(s', decls') = addVars s decls+>	addVars s (RecStmt stmts) =+>		(s', RecStmt stmts')+>		where	(s', stmts') = addVars s stmts+>	addVars s stmt@(LetCmdStmt _vdecl) =+>		(s, stmt)++Translation of case commands uses a right-nested sum,+corresponding to the right-associativity of (|||).+(In future: use a balanced sum.)++The state kept while traversing the expression is+	(count of rhss, rhss in reverse order)++> transCase :: TransState -> HsPat -> HsExp -> [Alt] -> Arrow+> transCase s p e as =+>	arr 0 (input s) p (HsCase e as') >>> foldr1 (|||) (reverse cases)+>	where	(as', (ncases, cases)) =+>			runState (mapM (transAlt s) as) (0, [])+>		transAlt s (Alt loc p gas decls) = do+>			let	(s', p') = addVars s p+>				(s'', decls') = addVars s' decls+>			gas' <- transGuardedAlts s'' gas+>			return (HsAlt loc p' gas' decls')+>		transGuardedAlts s (UnGuardedAlt c) = do+>			body <- newAlt s c+>			return (HsUnGuardedAlt body)+>		transGuardedAlts s (GuardedAlts gas) = do+>			gas' <- mapM (transGuardedAlt s) gas+>			return (HsGuardedAlts gas')+>		transGuardedAlt s (GuardedAlt loc e c) = do+>			body <- newAlt s c+>			return (HsGuardedAlt loc e body)+>		newAlt s c = do+>			let (e, a) = transTrimCmd s c+>			(n, as) <- get+>			put (n+1, a:as)+>			return (label n e)+>		label n e = times n right+>				(if n < ncases-1 then left e else e)
+ src/Control/Arrow/QuasiQuoter.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Control.Arrow.QuasiQuoter+  ( proc+  , parseModuleWithMode+  ) where++import Data.Maybe++import Language.Haskell.TH+import Language.Haskell.TH.Quote++import Language.Haskell.ParseMonad+import Language.Haskell.Syntax+import Language.Haskell.Pretty++import Parser++import Text.Printf++-- | A quasiquoter for arrow notation.+--   To be used as follows:+--+--   @+--      arr f = BST [proc| (b, s) -> do+-- 			returnA -< (f b, s) |]+--   @++proc :: QuasiQuoter+proc = QuasiQuoter+  { quoteExp  = quote+  , quotePat  = error "proc: pattern quotes not supported"+  , quoteType = error "proc: type quotes not supported"+  , quoteDec  = error "proc: dec quotes not supported"+  }++quote :: String -> Q Exp+quote inp =+  case parseProc ("proc " ++ inp) of+    ParseOk proc -> tr proc+    ParseFailed loc err -> do+      Loc{..} <- location+      error $ printf "%s:%d:%d: %s" loc_filename+                                   (fst loc_start + srcLine loc - 1)+                                   (snd loc_start + srcColumn loc - 1)+                                   err++class Translate hs th | hs -> th where+  tr :: hs -> Q th++trAll xx = traverse tr xx++instance Translate HsExp Exp where+  tr (HsVar name) = VarE <$> tr name+  tr (HsCon (Special HsUnitCon)) = [|()|]+  tr (HsCon (Special HsListCon)) = [|[]|]+  tr (HsCon (Special HsCons)) = [| (:) |]+  tr (HsCon (Special (HsTupleCon 2))) = [| (,) |]+  tr (HsCon (Special (HsTupleCon 3))) = [| (,,) |]+  tr (HsCon (Special (HsTupleCon 4))) = [| (,,,) |]+  tr (HsCon name) = ConE <$> tr name+  tr (HsLit lit)  = LitE <$> tr lit+  tr (HsInfixApp a op b) =+    InfixE <$> (Just <$> tr a) <*> tr op <*> (Just <$> tr b)+  tr (HsApp a b) = AppE <$> tr a <*> tr b+  tr (HsLambda _ pats e) = LamE <$> trAll pats <*> tr e+  tr (HsLet decs e) = LetE <$> trAll decs <*> tr e+  tr (HsIf c t e) = CondE <$> tr c <*> tr t <*> tr e+  tr (HsCase e aa) = CaseE <$> tr e <*> trAll aa+  tr (HsDo ss) = DoE <$> trAll ss+  tr (HsTuple ee) = TupE <$> trAll ee+  tr (HsList ee) = ListE <$> trAll ee+  tr (HsParen e) = ParensE <$> tr e+  tr (HsLeftSection  e op) = InfixE <$> (Just <$> tr e) <*> tr op <*> pure Nothing+  tr (HsRightSection op e) = InfixE <$> pure Nothing    <*> tr op <*> (Just <$> tr e)+  tr (HsRecConstr n ff) = RecConE <$> tr n <*> trAll ff+  tr (HsRecUpdate e ff) = RecUpdE <$> tr e <*> trAll ff+  tr (HsEnumFrom e) = ArithSeqE . FromR <$> tr e+  tr (HsEnumFromThen f t) = ArithSeqE <$> (FromThenR <$> tr f <*> tr t)+  tr (HsEnumFromThenTo f t to) = ArithSeqE <$> (FromThenToR <$> tr f <*> tr t <*> tr to)+  tr (HsEnumFromTo f to) = ArithSeqE <$> (FromToR <$> tr f <*> tr to)+  tr (HsListComp e ss) = (\e ss -> CompE (ss ++ [NoBindS e])) <$> tr e <*> trAll ss+  tr (HsExpTypeSig _ e _) = tr e+  tr HsNegApp{} = error "not applicable"+  tr HsWildCard = error "not applicable"+  tr HsAsPat{} = error "not applicable"+  tr HsIrrPat{} = error "not applicable"++instance Translate HsDecl Dec where+  tr (HsFunBind mm@(HsMatch _ n _ _ _ : _)) = FunD <$> (mkName <$> tr n) <*> trAll mm+  tr (HsPatBind _ p r dd) = ValD <$> tr p <*> tr r <*> trAll dd+  tr _ = error "not implemented: HsDecl"++instance Translate HsMatch Clause where+  tr (HsMatch _ _ pats rhs decls) = Clause <$> trAll pats <*> tr rhs <*> trAll decls++instance Translate HsAlt Match where+  tr (HsAlt _ p aa dd ) = Match <$> tr p <*> tr aa <*> trAll dd++instance Translate HsGuardedAlts Body where+  tr (HsGuardedAlts aa) = GuardedB <$> trAll aa+  tr (HsUnGuardedAlt e) = NormalB <$> tr e++instance Translate HsGuardedAlt (Guard,Exp) where+  tr (HsGuardedAlt _ e e') = (,) <$> (NormalG <$> tr e) <*> tr e'++instance Translate HsStmt Stmt where+  tr (HsGenerator _ p e) = BindS <$> tr p <*> tr e+  tr (HsQualifier e) = NoBindS <$> tr e+  tr (HsLetStmt dd)  = LetS <$> trAll dd++instance Translate HsFieldUpdate FieldExp where+  tr (HsFieldUpdate n e) = (,) <$> tr n <*> tr e++instance Translate HsRhs Body where+  tr (HsUnGuardedRhs e) = NormalB <$> tr e+  tr (HsGuardedRhss gg) = GuardedB <$> trAll gg++instance Translate HsGuardedRhs (Guard,Exp) where+  tr (HsGuardedRhs _ e e') = (,) . NormalG <$> tr e <*> tr e'++instance Translate HsLiteral Lit where+  tr (HsChar c) = pure $ CharL c+  tr (HsString s) = pure $ StringL s+  tr (HsInt i) = pure $ IntPrimL i+  tr (HsFrac f) = pure $ RationalL f+  tr (HsCharPrim c) = pure $ CharPrimL c+  tr (HsIntPrim c) = pure $ IntPrimL c+  tr (HsStringPrim s) = pure $ StringL s+  tr (HsFloatPrim s) = pure $ FloatPrimL s+  tr (HsDoublePrim x) = pure $ DoublePrimL x++instance Translate HsQOp Exp where+  tr (HsQVarOp n) = VarE <$> tr n+  tr (HsQConOp n) = VarE <$> tr n++instance Translate HsPat Pat where+  tr (HsPVar n) = VarP . mkName <$> tr n+  tr (HsPLit l) = LitP <$> tr l+  tr (HsPInfixApp p1 n p2) = InfixP <$> tr p1 <*> tr n <*> tr p2+  tr (HsPApp n pats) = ConP <$> tr n <*> trAll pats+  tr (HsPTuple pats) = TupP <$> trAll pats+  tr (HsPList pats)  = ListP <$> trAll pats+  tr (HsPParen pat)  = ParensP <$> tr pat+  tr (HsPRec n pats) = RecP <$> tr n <*> trAll pats+  tr  HsPWildCard    = return WildP+  tr (HsPIrrPat pat) = TildeP <$> tr pat+  tr HsPNeg{} = error "not implemented: HsPNeg"+  tr HsPAsPat{} = error "not implemented: HsPAsPat"++instance Translate HsPatField FieldPat where+  tr (HsPFieldPat n pat) = (,) <$> tr n <*> tr pat++instance Translate HsQName Name where+  tr (UnQual n) = do+    n <- tr n+    return $ mkName n+  tr (Qual (Module m) n) = do+    n <- tr n+    fromMaybe (error $ printf "Not found: %s.%s" m n) <$> lookupValueName (m ++ "." ++ n)+  tr (Special (HsTupleCon 2)) = error "unhandled Special tuplecon id"+  tr (Special HsUnitCon) =  error "unhandled special unitcon id"+  tr (Special HsListCon) = error "unhandled special listcon id"+  tr (Special HsFunCon) = error "unhandled special funcon id"+  tr (Special HsCons) = error "unhandled special cons id"+++instance Translate HsName [Char] where+  tr (HsSymbol s) = return s+  tr (HsIdent  n) = return n
+ src/Lexer.hs view
@@ -0,0 +1,564 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Lexer+-- Copyright   :  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Lexer for Haskell.+--+-----------------------------------------------------------------------------++-- ToDo: Introduce different tokens for decimal, octal and hexadecimal (?)+-- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?)+-- ToDo: Use a lexical analyser generator (lx?)++module Lexer (Token(..), lexer) where++import Language.Haskell.ParseMonad++import Data.Char	(isAlpha, isLower, isUpper, toLower,+			 isDigit, isHexDigit, isOctDigit, isSpace,+			 ord, chr, digitToInt)+import Data.Ratio++data Token+        = VarId String+        | QVarId (String,String)+	| ConId String+        | QConId (String,String)+        | VarSym String+        | ConSym String+        | QVarSym (String,String)+        | QConSym (String,String)+	| IntTok Integer+	| FloatTok Rational+	| Character Char+        | StringTok String++-- Symbols++	| LeftParen+	| RightParen+	| SemiColon+        | LeftCurly+        | RightCurly+        | VRightCurly			-- a virtual close brace+        | LeftSquare+        | RightSquare+	| Comma+        | Underscore+        | BackQuote++-- Reserved operators++	| DotDot+	| Colon+	| DoubleColon+	| Equals+	| Backslash+	| Bar+	| LeftArrow+	| RightArrow+	| At+	| Tilde+	| DoubleArrow+	| Minus+	| Exclamation+	| LeftArrowTail		-- added for arrows+	| RightArrowTail	-- added for arrows+	| LeftArrowDTail	-- added for arrows+	| RightArrowDTail	-- added for arrows+	| LeftBanana		-- added for arrows+	| RightBanana		-- added for arrows++-- Reserved Ids++	| KW_Case+	| KW_Class+	| KW_Data+	| KW_Default+	| KW_Deriving+	| KW_Do+	| KW_Else+	| KW_Foreign+	| KW_If+	| KW_Import+	| KW_In+	| KW_Infix+	| KW_InfixL+	| KW_InfixR+	| KW_Instance+	| KW_Let+	| KW_Module+	| KW_NewType+	| KW_Of+	| KW_Then+	| KW_Type+	| KW_Where++-- Special Ids++	| KW_As+	| KW_Export+	| KW_Hiding+	| KW_Qualified+	| KW_Safe+	| KW_Unsafe+	| KW_Proc		-- added for arrows+	| KW_Rec		-- added for arrows+	| KW_Form		-- added for arrows+	| KW_Cmd		-- added for arrows++        | EOF+        deriving (Eq,Show)++reserved_ops :: [(String,Token)]+reserved_ops = [+ ( "..", DotDot ),+ ( ":",  Colon ),+ ( "::", DoubleColon ),+ ( "=",  Equals ),+ ( "\\", Backslash ),+ ( "|",  Bar ),+ ( "<-", LeftArrow ),+ ( "->", RightArrow ),+ ( "@",  At ),+ ( "~",  Tilde ),+ ( "=>", DoubleArrow ),+ ( "-<", LeftArrowTail ),	-- added for arrows+ ( ">-", RightArrowTail ),	-- added for arrows+ ( "-<<", LeftArrowDTail ),	-- added for arrows+ ( ">>-", RightArrowDTail ),	-- added for arrows+ ( "\\<", Backslash )		-- added for arrows+ ]++special_varops :: [(String,Token)]+special_varops = [+ ( "-",  Minus ),			--ToDo: shouldn't be here+ ( "!",  Exclamation )		--ditto+ ]++reserved_ids :: [(String,Token)]+reserved_ids = [+ ( "_",         Underscore ),+ ( "case",      KW_Case ),+ ( "class",     KW_Class ),+ ( "cmd",	KW_Cmd ),	-- added for arrows+ ( "data",      KW_Data ),+ ( "default",   KW_Default ),+ ( "deriving",  KW_Deriving ),+ ( "do",        KW_Do ),+ ( "else",      KW_Else ),+ ( "foreign",	KW_Foreign ),+ ( "if",    	KW_If ),+ ( "import",    KW_Import ),+ ( "in", 	KW_In ),+ ( "infix", 	KW_Infix ),+ ( "infixl", 	KW_InfixL ),+ ( "infixr", 	KW_InfixR ),+ ( "instance",  KW_Instance ),+ ( "let", 	KW_Let ),+ ( "module", 	KW_Module ),+ ( "newtype",   KW_NewType ),+ ( "of", 	KW_Of ),+ ( "proc",	KW_Proc ),	-- added for arrows+ ( "rec",	KW_Rec ),	-- added for arrows+ ( "then", 	KW_Then ),+ ( "type", 	KW_Type ),+ ( "where", 	KW_Where )+ ]++special_varids :: [(String,Token)]+special_varids = [+ ( "as", 	KW_As ),+ ( "export", 	KW_Export ),+ ( "hiding", 	KW_Hiding ),+ ( "qualified", KW_Qualified ),+ ( "safe",	KW_Safe ),+ ( "unsafe", 	KW_Unsafe )+ ]++isIdent, isSymbol :: Char -> Bool+isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'+isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"++matchChar :: Char -> String -> Lex a ()+matchChar c msg = do+	s <- getInput+	if null s || head s /= c then fail msg else discard 1++-- The top-level lexer.+-- We need to know whether we are at the beginning of the line to decide+-- whether to insert layout tokens.++lexer :: (Token -> P a) -> P a+lexer = runL $ do+	bol <- checkBOL+	bol <- lexWhiteSpace bol+	startToken+	if bol then lexBOL else lexToken++lexWhiteSpace :: Bool -> Lex a Bool+lexWhiteSpace bol = do+	s <- getInput+	case s of+	    '{':'-':_ -> do+		discard 2+		bol <- lexNestedComment bol+		lexWhiteSpace bol+	    '-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do+		lexWhile (== '-')+		lexWhile (/= '\n')+		s' <- getInput+		case s' of+		    [] -> fail "Unterminated end-of-line comment"+		    _ -> do+			lexNewline+			lexWhiteSpace True+	    '\n':_ -> do+		lexNewline+		lexWhiteSpace True+	    '\t':_ -> do+		lexTab+		lexWhiteSpace bol+	    c:_ | isSpace c -> do+		discard 1+		lexWhiteSpace bol+	    _ -> return bol++lexNestedComment :: Bool -> Lex a Bool+lexNestedComment bol = do+	s <- getInput+	case s of+	    '-':'}':_ -> discard 2 >> return bol+	    '{':'-':_ -> do+		discard 2+		bol <- lexNestedComment bol	-- rest of the subcomment+		lexNestedComment bol		-- rest of this comment+	    '\t':_    -> lexTab >> lexNestedComment bol+	    '\n':_    -> lexNewline >> lexNestedComment True+	    _:_       -> discard 1 >> lexNestedComment bol+	    []        -> fail "Unterminated nested comment"++-- When we are lexing the first token of a line, check whether we need to+-- insert virtual semicolons or close braces due to layout.++lexBOL :: Lex a Token+lexBOL = do+	pos <- getOffside+	case pos of+	    LT -> do+                -- trace "layout: inserting '}'\n" $+        	-- Set col to 0, indicating that we're still at the+        	-- beginning of the line, in case we need a semi-colon too.+        	-- Also pop the context here, so that we don't insert+        	-- another close brace before the parser can pop it.+		setBOL+		popContextL "lexBOL"+		return VRightCurly+	    EQ ->+                -- trace "layout: inserting ';'\n" $+		return SemiColon+	    GT ->+		lexToken++lexToken :: Lex a Token+lexToken = do+    s <- getInput+    case s of+        [] -> return EOF++	'0':c:d:_ | toLower c == 'o' && isOctDigit d -> do+			discard 2+			n <- lexOctal+			return (IntTok n)+		  | toLower c == 'x' && isHexDigit d -> do+			discard 2+			n <- lexHexadecimal+			return (IntTok n)++	'(':'|':c:_ | not (isSymbol c) -> do+	    discard 2+	    return LeftBanana++	'|':')':_ -> do+	    discard 2+	    return RightBanana++	c:_ | isDigit c -> lexDecimalOrFloat++	    | isUpper c -> lexConIdOrQual ""++	    | isLower c || c == '_' -> do+		ident <- lexWhile isIdent+		return $ case lookup ident (reserved_ids ++ special_varids) of+			Just keyword -> keyword+			Nothing -> VarId ident++	    | isSymbol c -> do+		sym <- lexWhile isSymbol+		return $ case lookup sym (reserved_ops ++ special_varops) of+			Just t  -> t+			Nothing -> case c of+			    ':' -> ConSym sym+			    _   -> VarSym sym++	    | otherwise -> do+		discard 1+		case c of++		    -- First the special symbols+		    '(' ->  return LeftParen+		    ')' ->  return RightParen+		    ',' ->  return Comma+		    ';' ->  return SemiColon+		    '[' ->  return LeftSquare+		    ']' ->  return RightSquare+		    '`' ->  return BackQuote+		    '{' -> do+			    pushContextL NoLayout+			    return LeftCurly+		    '}' -> do+			    popContextL "lexToken"+			    return RightCurly++		    '\'' -> do+			    c2 <- lexChar+			    matchChar '\'' "Improperly terminated character constant"+			    return (Character c2)++		    '"' ->  lexString++		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")++lexDecimalOrFloat :: Lex a Token+lexDecimalOrFloat = do+	ds <- lexWhile isDigit+	rest <- getInput+	case rest of+	    ('.':d:_) | isDigit d -> do+		discard 1+		frac <- lexWhile isDigit+		let num = parseInteger 10 (ds ++ frac)+		    decimals = toInteger (length frac)+		exponent <- do+			rest2 <- getInput+			case rest2 of+			    'e':_ -> lexExponent+			    'E':_ -> lexExponent+			    _     -> return 0+		return (FloatTok ((num%1) * 10^^(exponent - decimals)))+	    e:_ | toLower e == 'e' -> do+		exponent <- lexExponent+		return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent))+	    _ -> return (IntTok (parseInteger 10 ds))++    where+	lexExponent :: Lex a Integer+	lexExponent = do+		discard 1	-- 'e' or 'E'+		r <- getInput+		case r of+		    '+':d:_ | isDigit d -> do+			discard 1+			lexDecimal+		    '-':d:_ | isDigit d -> do+			discard 1+			n <- lexDecimal+			return (negate n)+		    d:_ | isDigit d -> lexDecimal+		    _ -> fail "Float with missing exponent"++lexConIdOrQual :: String -> Lex a Token+lexConIdOrQual qual = do+	con <- lexWhile isIdent+	let conid | null qual = ConId con+		  | otherwise = QConId (qual,con)+	    qual' | null qual = con+		  | otherwise = qual ++ '.':con+	just_a_conid <- alternative (return conid)+	rest <- getInput+	case rest of+	  '.':c:_+	     | isLower c || c == '_' -> do	-- qualified varid?+		discard 1+		ident <- lexWhile isIdent+		case lookup ident reserved_ids of+		   -- cannot qualify a reserved word+		   Just _  -> just_a_conid+		   Nothing -> return (QVarId (qual', ident))++	     | isUpper c -> do		-- qualified conid?+		discard 1+		lexConIdOrQual qual'++	     | isSymbol c -> do	-- qualified symbol?+		discard 1+		sym <- lexWhile isSymbol+		case lookup sym reserved_ops of+		    -- cannot qualify a reserved operator+		    Just _  -> just_a_conid+		    Nothing -> return $ case c of+			':' -> QConSym (qual', sym)+			_   -> QVarSym (qual', sym)++	  _ ->	return conid -- not a qualified thing++lexChar :: Lex a Char+lexChar = do+	r <- getInput+	case r of+		'\\':_	-> lexEscape+		c:_	-> discard 1 >> return c+		[]	-> fail "Incomplete character constant"++lexString :: Lex a Token+lexString = loop ""+    where+	loop s = do+		r <- getInput+		case r of+		    '\\':'&':_ -> do+				discard 2+				loop s+		    '\\':c:_ | isSpace c -> do+				discard 1+				lexWhiteChars+				matchChar '\\' "Illegal character in string gap"+				loop s+			     | otherwise -> do+				ce <- lexEscape+				loop (ce:s)+		    '"':_ -> do+				discard 1+				return (StringTok (reverse s))+		    c:_ -> do+				discard 1+				loop (c:s)+		    [] ->	fail "Improperly terminated string"++	lexWhiteChars :: Lex a ()+	lexWhiteChars = do+		s <- getInput+		case s of+		    '\n':_ -> do+			lexNewline+			lexWhiteChars+		    '\t':_ -> do+			lexTab+			lexWhiteChars+		    c:_ | isSpace c -> do+			discard 1+			lexWhiteChars+		    _ -> return ()++lexEscape :: Lex a Char+lexEscape = do+	discard 1+	r <- getInput+	case r of++-- Production charesc from section B.2 (Note: \& is handled by caller)++		'a':_		-> discard 1 >> return '\a'+		'b':_		-> discard 1 >> return '\b'+		'f':_		-> discard 1 >> return '\f'+		'n':_		-> discard 1 >> return '\n'+		'r':_		-> discard 1 >> return '\r'+		't':_		-> discard 1 >> return '\t'+		'v':_		-> discard 1 >> return '\v'+		'\\':_		-> discard 1 >> return '\\'+		'"':_		-> discard 1 >> return '\"'+		'\'':_		-> discard 1 >> return '\''++-- Production ascii from section B.2++		'^':c:_		-> discard 2 >> cntrl c+		'N':'U':'L':_	-> discard 3 >> return '\NUL'+		'S':'O':'H':_	-> discard 3 >> return '\SOH'+		'S':'T':'X':_	-> discard 3 >> return '\STX'+		'E':'T':'X':_	-> discard 3 >> return '\ETX'+		'E':'O':'T':_	-> discard 3 >> return '\EOT'+		'E':'N':'Q':_	-> discard 3 >> return '\ENQ'+		'A':'C':'K':_	-> discard 3 >> return '\ACK'+		'B':'E':'L':_	-> discard 3 >> return '\BEL'+		'B':'S':_	-> discard 2 >> return '\BS'+		'H':'T':_	-> discard 2 >> return '\HT'+		'L':'F':_	-> discard 2 >> return '\LF'+		'V':'T':_	-> discard 2 >> return '\VT'+		'F':'F':_	-> discard 2 >> return '\FF'+		'C':'R':_	-> discard 2 >> return '\CR'+		'S':'O':_	-> discard 2 >> return '\SO'+		'S':'I':_	-> discard 2 >> return '\SI'+		'D':'L':'E':_	-> discard 3 >> return '\DLE'+		'D':'C':'1':_	-> discard 3 >> return '\DC1'+		'D':'C':'2':_	-> discard 3 >> return '\DC2'+		'D':'C':'3':_	-> discard 3 >> return '\DC3'+		'D':'C':'4':_	-> discard 3 >> return '\DC4'+		'N':'A':'K':_	-> discard 3 >> return '\NAK'+		'S':'Y':'N':_	-> discard 3 >> return '\SYN'+		'E':'T':'B':_	-> discard 3 >> return '\ETB'+		'C':'A':'N':_	-> discard 3 >> return '\CAN'+		'E':'M':_	-> discard 2 >> return '\EM'+		'S':'U':'B':_	-> discard 3 >> return '\SUB'+		'E':'S':'C':_	-> discard 3 >> return '\ESC'+		'F':'S':_	-> discard 2 >> return '\FS'+		'G':'S':_	-> discard 2 >> return '\GS'+		'R':'S':_	-> discard 2 >> return '\RS'+		'U':'S':_	-> discard 2 >> return '\US'+		'S':'P':_	-> discard 2 >> return '\SP'+		'D':'E':'L':_	-> discard 3 >> return '\DEL'++-- Escaped numbers++		'o':c:_ | isOctDigit c -> do+					discard 1+					n <- lexOctal+					checkChar n+		'x':c:_ | isHexDigit c -> do+					discard 1+					n <- lexHexadecimal+					checkChar n+		c:_ | isDigit c -> do+					n <- lexDecimal+					checkChar n++		_		-> fail "Illegal escape sequence"++    where+	checkChar n | n <= 0x10FFFF = return (chr (fromInteger n))+	checkChar _		    = fail "Character constant out of range"++-- Production cntrl from section B.2++	cntrl :: Char -> Lex a Char+	cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))+	cntrl _                        = fail "Illegal control character"++-- assumes at least one octal digit+lexOctal :: Lex a Integer+lexOctal = do+	ds <- lexWhile isOctDigit+	return (parseInteger 8 ds)++-- assumes at least one hexadecimal digit+lexHexadecimal :: Lex a Integer+lexHexadecimal = do+	ds <- lexWhile isHexDigit+	return (parseInteger 16 ds)++-- assumes at least one decimal digit+lexDecimal :: Lex a Integer+lexDecimal = do+	ds <- lexWhile isDigit+	return (parseInteger 10 ds)++-- Stolen from Hugs's Prelude+parseInteger :: Integer -> String -> Integer+parseInteger radix ds =+	foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)
+ src/Parser.ly view
@@ -0,0 +1,997 @@+> {+> -----------------------------------------------------------------------------+> -- |+> -- Module      :  Parser+> -- Copyright   :  (c) Simon Marlow, Sven Panne 1997-2000+> -- License     :  BSD-style (see the file libraries/base/LICENSE)+> --+> -- Maintainer  :  libraries@haskell.org+> -- Stability   :  experimental+> -- Portability :  portable+> --+> -- Haskell parser.+> --+> -----------------------------------------------------------------------------+>+> module Parser (+>		parseModule, parseModuleWithMode,+>		ParseMode(..), defaultParseMode, ParseResult(..),+>   parseProc+>   ) where+> +> import Language.Haskell.Syntax+> import Language.Haskell.ParseMonad+> import Lexer+> import Language.Haskell.ParseUtils+> +> import qualified ArrSyn		-- added for arrows+> }++ToDo: Check exactly which names must be qualified with Prelude (commas and friends)+ToDo: Inst (MPCs?)+ToDo: Polish constr a bit+ToDo: Ugly: exp0b is used for lhs, pat, exp0, ...+ToDo: Differentiate between record updates and labeled construction.++-----------------------------------------------------------------------------+Conflicts: 2 shift/reduce++2 for ambiguity in 'case x of y | let z = y in z :: Bool -> b'+	(don't know whether to reduce 'Bool' as a btype or shift the '->'.+	 Similarly lambda and if.  The default resolution in favour of the+	 shift means that a guard can never end with a type signature.+	 In mitigation: it's a rare case and no Haskell implementation+	 allows these, because it would require unbounded lookahead.)+	There are 2 conflicts rather than one because contexts are parsed+	as btypes (cf ctype).++-----------------------------------------------------------------------------++> %token+>	VARID 	 { VarId $$ }+>	QVARID 	 { QVarId $$ }+>	CONID	 { ConId $$ }+>	QCONID   { QConId $$ }+>	VARSYM	 { VarSym $$ }+>	CONSYM	 { ConSym $$ }+>	QVARSYM	 { QVarSym $$ }+>	QCONSYM  { QConSym $$ }+>	INT	 { IntTok $$ }+>	RATIONAL { FloatTok $$ }+>	CHAR	 { Character $$ }+>	STRING   { StringTok $$ }++Symbols++>	'('	{ LeftParen }+>	')'	{ RightParen }+>	';'	{ SemiColon }+>	'{'	{ LeftCurly }+>	'}'	{ RightCurly }+>	vccurly { VRightCurly }			-- a virtual close brace+>	'['	{ LeftSquare }+>	']'	{ RightSquare }+>  	','	{ Comma }+>	'_'	{ Underscore }+>	'`'	{ BackQuote }++Reserved operators++>	'..'	{ DotDot }+>	':'	{ Colon }+>	'::'	{ DoubleColon }+>	'='	{ Equals }+>	'\\'	{ Backslash }+>	'|'	{ Bar }+>	'<-'	{ LeftArrow }+>	'->'	{ RightArrow }+>	'@'	{ At }+>	'~'	{ Tilde }+>	'=>'	{ DoubleArrow }+>	'-<'	{ LeftArrowTail }		-- added for arrows+>	'>-'	{ RightArrowTail }		-- added for arrows+>	'-<<'	{ LeftArrowDTail }		-- added for arrows+>	'>>-'	{ RightArrowDTail }		-- added for arrows+>	'(|'	{ LeftBanana }			-- added for arrows+>	'|)'	{ RightBanana }			-- added for arrows+>	'-'	{ Minus }+>	'!'	{ Exclamation }++Reserved Ids++>	'case'		{ KW_Case }+>	'class'		{ KW_Class }+>	'data'		{ KW_Data }+>	'default'	{ KW_Default }+>	'deriving'	{ KW_Deriving }+>	'do'		{ KW_Do }+>	'else'		{ KW_Else }+>	'foreign'	{ KW_Foreign }+>	'if'		{ KW_If }+>	'import'	{ KW_Import }+>	'in'		{ KW_In }+>	'infix'		{ KW_Infix }+>	'infixl'	{ KW_InfixL }+>	'infixr'	{ KW_InfixR }+>	'instance'	{ KW_Instance }+>	'let'		{ KW_Let }+>	'module'	{ KW_Module }+>	'newtype'	{ KW_NewType }+>	'of'		{ KW_Of }+>	'then'		{ KW_Then }+>	'type'		{ KW_Type }+>	'where'		{ KW_Where }++Special Ids++>	'as'		{ KW_As }+>	'export'	{ KW_Export }+>	'hiding'	{ KW_Hiding }+>	'qualified'	{ KW_Qualified }+>	'safe'		{ KW_Safe }+>	'unsafe'	{ KW_Unsafe }+>	'proc'		{ KW_Proc }		-- added for arrows+>	'rec'		{ KW_Rec }		-- added for arrows+>	'cmd'		{ KW_Cmd }		-- added for arrows++> %monad { P }+> %lexer { lexer } { EOF }+> %name parse module+> %name parseProcExp procExp+> %tokentype { Token }+> %%++-----------------------------------------------------------------------------+Module Header++> module :: { HsModule }+>	: srcloc 'module' modid maybeexports 'where' body+>		{ HsModule $1 $3 $4 (fst $6) (snd $6) }+>	| srcloc body+>		{ HsModule $1 main_mod (Just [HsEVar (UnQual main_name)])+>							(fst $2) (snd $2) }++> body :: { ([HsImportDecl],[HsDecl]) }+>	: '{'  bodyaux '}'			{ $2 }+>	| open bodyaux close			{ $2 }++> bodyaux :: { ([HsImportDecl],[HsDecl]) }+>	: optsemis impdecls semis topdecls	{ (reverse $2, $4) }+>	| optsemis                topdecls	{ ([], $2) }+>	| optsemis impdecls optsemis		{ (reverse $2, []) }+>	| optsemis				{ ([], []) }++> semis :: { () }+>	: optsemis ';'				{ () }++> optsemis :: { () }+>	: semis					{ () }+>	| {- empty -}				{ () }++-----------------------------------------------------------------------------+The Export List++> maybeexports :: { Maybe [HsExportSpec] }+> 	:  exports				{ Just $1 }+> 	|  {- empty -}				{ Nothing }++> exports :: { [HsExportSpec] }+>	: '(' exportlist optcomma ')'		{ reverse $2 }+>	| '(' optcomma ')'			{ [] }++> optcomma :: { () }+>	: ','					{ () }+>	| {- empty -}				{ () }++> exportlist :: { [HsExportSpec] }+> 	:  exportlist ',' export		{ $3 : $1 }+> 	|  export				{ [$1]  }++> export :: { HsExportSpec }+> 	:  qvar					{ HsEVar $1 }+> 	|  qtyconorcls				{ HsEAbs $1 }+> 	|  qtyconorcls '(' '..' ')'		{ HsEThingAll $1 }+> 	|  qtyconorcls '(' ')'		        { HsEThingWith $1 [] }+>	|  qtyconorcls '(' cnames ')'		{ HsEThingWith $1 (reverse $3) }+> 	|  'module' modid			{ HsEModuleContents $2 }++-----------------------------------------------------------------------------+Import Declarations++> impdecls :: { [HsImportDecl] }+>	: impdecls semis impdecl		{ $3 : $1 }+>	| impdecl				{ [$1] }++> impdecl :: { HsImportDecl }+>	: srcloc 'import' optqualified modid maybeas maybeimpspec+>				{ HsImportDecl $1 $4 $3 $5 $6 }++> optqualified :: { Bool }+>       : 'qualified'                           { True  }+>       | {- empty -}				{ False }++> maybeas :: { Maybe Module }+>       : 'as' modid                            { Just $2 }+>       | {- empty -}				{ Nothing }+++> maybeimpspec :: { Maybe (Bool, [HsImportSpec]) }+>	: impspec				{ Just $1 }+>	| {- empty -}				{ Nothing }++> impspec :: { (Bool, [HsImportSpec]) }+>	: opthiding '(' importlist optcomma ')'	{ ($1, reverse $3) }+>	| opthiding '(' optcomma ')'		{ ($1, []) }++> opthiding :: { Bool }+>	: 'hiding'				{ True }+>	| {- empty -}				{ False }++> importlist :: { [HsImportSpec] }+> 	:  importlist ',' importspec		{ $3 : $1 }+> 	|  importspec				{ [$1]  }++> importspec :: { HsImportSpec }+> 	:  var					{ HsIVar $1 }+> 	|  tyconorcls				{ HsIAbs $1 }+> 	|  tyconorcls '(' '..' ')'		{ HsIThingAll $1 }+> 	|  tyconorcls '(' ')'		        { HsIThingWith $1 [] }+> 	|  tyconorcls '(' cnames ')'		{ HsIThingWith $1 (reverse $3) }++> cnames :: { [HsCName] }+> 	:  cnames ',' cname			{ $3 : $1 }+> 	|  cname				{ [$1]  }++> cname :: { HsCName }+>	:  var					{ HsVarName $1 }+> 	|  con					{ HsConName $1 }++-----------------------------------------------------------------------------+Fixity Declarations++> fixdecl :: { HsDecl }+> 	: srcloc infix prec ops			{ HsInfixDecl $1 $2 $3 (reverse $4) }++> prec :: { Int }+>	: {- empty -}				{ 9 }+>	| INT					{% checkPrec $1 }++> infix :: { HsAssoc }+>	: 'infix'				{ HsAssocNone  }+>	| 'infixl'				{ HsAssocLeft  }+>	| 'infixr'				{ HsAssocRight }++> ops   :: { [HsOp] }+>	: ops ',' op				{ $3 : $1 }+>	| op					{ [$1] }++-----------------------------------------------------------------------------+Top-Level Declarations++Note: The report allows topdecls to be empty. This would result in another+shift/reduce-conflict, so we don't handle this case here, but in bodyaux.++> topdecls :: { [HsDecl] }+>	: topdecls1 optsemis		{% checkRevDecls $1 }++> topdecls1 :: { [HsDecl] }+>	: topdecls1 semis topdecl	{ $3 : $1 }+>	| topdecl			{ [$1] }++> topdecl :: { HsDecl }+>	: srcloc 'type' simpletype '=' type+>			{ HsTypeDecl $1 (fst $3) (snd $3) $5 }+>	| srcloc 'data' ctype '=' constrs deriving+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsDataDecl $1 cs c t (reverse $5) $6) } }+>	| srcloc 'newtype' ctype '=' constr deriving+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsNewTypeDecl $1 cs c t $5 $6) } }+>	| srcloc 'class' ctype optcbody+>			{% do { (cs,c,vs) <- checkClassHeader $3;+>				return (HsClassDecl $1 cs c vs $4) } }+>	| srcloc 'instance' ctype optvaldefs+>			{% do { (cs,c,ts) <- checkInstHeader $3;+>				return (HsInstDecl $1 cs c ts $4) } }+>	| srcloc 'default' '(' typelist ')'+>			{ HsDefaultDecl $1 $4 }+>	| foreigndecl	{ $1 }+>       | decl		{ $1 }++> typelist :: { [HsType] }+>	: types				{ reverse $1 }+>	| type				{ [$1] }+>	| {- empty -}			{ [] }++> decls :: { [HsDecl] }+>	: optsemis decls1 optsemis	{% checkRevDecls $2 }+>	| optsemis			{ [] }++> decls1 :: { [HsDecl] }+>	: decls1 semis decl		{ $3 : $1 }+>	| decl				{ [$1] }++> decl :: { HsDecl }+>	: signdecl			{ $1 }+>	| fixdecl			{ $1 }+>	| valdef			{ $1 }++> decllist :: { [HsDecl] }+>	: '{'  decls '}'		{ $2 }+>	| open decls close		{ $2 }++> signdecl :: { HsDecl }+>	: srcloc vars '::' ctype	{ HsTypeSig $1 (reverse $2) $4 }++ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+instead of qvar, we get another shift/reduce-conflict. Consider the+following programs:++   { (+) :: ... }          only var+   { (+) x y  = ... }      could (incorrectly) be qvar++We re-use expressions for patterns, so a qvar would be allowed in patterns+instead of a var only (which would be correct). But deciding what the + is,+would require more lookahead. So let's check for ourselves...++> vars	:: { [HsName] }+>	: vars ',' var			{ $3 : $1 }+>	| qvar				{% do { n <- checkUnQual $1;+>						return [n] } }++Foreign declarations+- calling conventions are uninterpreted+- external entities are not parsed+- special ids are not allowed as internal names++> foreigndecl :: { HsDecl }+>	: srcloc 'foreign' 'import' VARID optsafety optentity fvar '::' type+>			{ HsForeignImport $1 $4 $5 $6 $7 $9 }+>	| srcloc 'foreign' 'export' VARID optentity fvar '::' type+>			{ HsForeignExport $1 $4 $5 $6 $8 }++> optsafety :: { HsSafety }+>	: 'safe'			{ HsSafe }+>	| 'unsafe'			{ HsUnsafe }+>	| {- empty -}			{ HsSafe }++> optentity :: { String }+>	: STRING			{ $1 }+>	| {- empty -}			{ "" }++> fvar :: { HsName }+>	: VARID				{ HsIdent $1 }+>	| '(' varsym ')'		{ $2 }++-----------------------------------------------------------------------------+Types++> type :: { HsType }+>	: btype '->' type		{ HsTyFun $1 $3 }+>	| btype				{ $1 }++> btype :: { HsType }+>	: btype atype			{ HsTyApp $1 $2 }+>	| atype				{ $1 }++> atype :: { HsType }+>	: gtycon			{ HsTyCon $1 }+>	| tyvar				{ HsTyVar $1 }+>	| '(' types ')'			{ HsTyTuple (reverse $2) }+>	| '[' type ']'			{ HsTyApp list_tycon $2 }+>	| '(' type ')'			{ $2 }++> gtycon :: { HsQName }+>	: qconid			{ $1 }+>	| '(' ')'			{ unit_tycon_name }+>	| '(' '->' ')'			{ fun_tycon_name }+>	| '[' ']'			{ list_tycon_name }+>	| '(' commas ')'		{ tuple_tycon_name $2 }+++(Slightly edited) Comment from GHC's hsparser.y:+"context => type" vs  "type" is a problem, because you can't distinguish between++	foo :: (Baz a, Baz a)+	bar :: (Baz a, Baz a) => [a] -> [a] -> [a]++with one token of lookahead.  The HACK is to parse the context as a btype+(more specifically as a tuple type), then check that it has the right form+C a, or (C1 a, C2 b, ... Cn z) and convert it into a context.  Blaach!++> ctype :: { HsQualType }+>	: context '=>' type		{ HsQualType $1 $3 }+>	| type				{ HsQualType [] $1 }++> context :: { HsContext }+>	: btype				{% checkContext $1 }++> types	:: { [HsType] }+>	: types ',' type		{ $3 : $1 }+>	| type  ',' type		{ [$3, $1] }++> simpletype :: { (HsName, [HsName]) }+>	: tycon tyvars			{ ($1,reverse $2) }++> tyvars :: { [HsName] }+>	: tyvars tyvar			{ $2 : $1 }+>	| {- empty -}			{ [] }++-----------------------------------------------------------------------------+Datatype declarations++> constrs :: { [HsConDecl] }+>	: constrs '|' constr		{ $3 : $1 }+>	| constr			{ [$1] }++> constr :: { HsConDecl }+>	: srcloc scontype		{ HsConDecl $1 (fst $2) (snd $2) }+>	| srcloc sbtype conop sbtype	{ HsConDecl $1 $3 [$2,$4] }+>	| srcloc con '{' '}'		{ HsRecDecl $1 $2 [] }+>	| srcloc con '{' fielddecls '}' { HsRecDecl $1 $2 (reverse $4) }++> scontype :: { (HsName, [HsBangType]) }+>	: btype				{% do { (c,ts) <- splitTyConApp $1;+>						return (c,map HsUnBangedTy ts) } }+>	| scontype1			{ $1 }++> scontype1 :: { (HsName, [HsBangType]) }+>	: btype '!' atype		{% do { (c,ts) <- splitTyConApp $1;+>						return (c,map HsUnBangedTy ts+++>							[HsBangedTy $3]) } }+>	| scontype1 satype		{ (fst $1, snd $1 ++ [$2] ) }++> satype :: { HsBangType }+>	: atype				{ HsUnBangedTy $1 }+>	| '!' atype			{ HsBangedTy   $2 }++> sbtype :: { HsBangType }+>	: btype				{ HsUnBangedTy $1 }+>	| '!' atype			{ HsBangedTy   $2 }++> fielddecls :: { [([HsName],HsBangType)] }+>	: fielddecls ',' fielddecl	{ $3 : $1 }+>	| fielddecl			{ [$1] }++> fielddecl :: { ([HsName],HsBangType) }+>	: vars '::' stype		{ (reverse $1, $3) }++> stype :: { HsBangType }+>	: type				{ HsUnBangedTy $1 }	+>	| '!' atype			{ HsBangedTy   $2 }++> deriving :: { [HsQName] }+>	: {- empty -}			{ [] }+>	| 'deriving' qtycls		{ [$2] }+>	| 'deriving' '('          ')'	{ [] }+>	| 'deriving' '(' dclasses ')'	{ reverse $3 }++> dclasses :: { [HsQName] }+>	: dclasses ',' qtycls		{ $3 : $1 }+>       | qtycls			{ [$1] }++-----------------------------------------------------------------------------+Class declarations++> optcbody :: { [HsDecl] }+>	: 'where' decllist		{% checkClassBody $2 }+>	| {- empty -}			{ [] }++-----------------------------------------------------------------------------+Instance declarations++> optvaldefs :: { [HsDecl] }+>	: 'where' '{'  valdefs '}'	{% checkClassBody $3 }+>	| 'where' open valdefs close	{% checkClassBody $3 }+>	| {- empty -}			{ [] }++> valdefs :: { [HsDecl] }+>	: optsemis valdefs1 optsemis	{% checkRevDecls $2 }+>	| optsemis			{ [] }++> valdefs1 :: { [HsDecl] }+>	: valdefs1 semis valdef		{ $3 : $1 }+>	| valdef			{ [$1] }++-----------------------------------------------------------------------------+Value definitions++> valdef :: { HsDecl }+>	: srcloc exp0b rhs optwhere	{% checkValDef $1 $2 $3 $4 }++> optwhere :: { [HsDecl] }+>	: 'where' decllist		{ $2 }+>	| {- empty -}			{ [] }++> rhs	:: { HsRhs }+>	: '=' exp			{% do { e <- checkExpr $2;+>						return (HsUnGuardedRhs e) } }+>	| gdrhs				{ HsGuardedRhss  (reverse $1) }++> gdrhs :: { [HsGuardedRhs] }+>	: gdrhs gdrh			{ $2 : $1 }+>	| gdrh				{ [$1] }++> gdrh :: { HsGuardedRhs }+>	: srcloc '|' exp0 '=' exp	{% do { g <- checkExpr $3;+>						e <- checkExpr $5;+>						return (HsGuardedRhs $1 g e) } }++-----------------------------------------------------------------------------+Expressions++Note: The Report specifies a meta-rule for lambda, let and if expressions+(the exp's that end with a subordinate exp): they extend as far to+the right as possible.  That means they cannot be followed by a type+signature or infix application.  To implement this without shift/reduce+conflicts, we split exp10 into these expressions (exp10a) and the others+(exp10b).  That also means that only an exp0 ending in an exp10b (an exp0b)+can followed by a type signature or infix application.  So we duplicate+the exp0 productions to distinguish these from the others (exp0a).++> exp   :: { HsExp }+>	: exp0b '::' srcloc ctype  	{ HsExpTypeSig $3 $1 $4 }+>	| exp0				{ $1 }++> exp0 :: { HsExp }+>	: exp0a				{ $1 }+>	| exp0b				{ $1 }++> exp0a :: { HsExp }+>	: exp0b qop exp10a		{ HsInfixApp $1 $2 $3 }+>	| exp10a			{ $1 }++> exp0b :: { HsExp }+>	: exp0b qop exp10b		{ HsInfixApp $1 $2 $3 }+>	| exp10b			{ $1 }++> exp10a :: { HsExp }+>	: '\\' srcloc apats '->' exp	{ HsLambda $2 (reverse $3) $5 }+>  	| 'let' decllist 'in' exp	{ HsLet $2 $4 }+>	| 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }+>	| procExp { $1 }++> procExp :: { HsExp }+> : 'proc' apat '->' cmd		{ ArrSyn.translate $2 $4 }++> exp10b :: { HsExp }+>	: 'case' exp 'of' altslist	{ HsCase $2 $4 }+>	| '-' fexp			{ HsNegApp $2 }+>  	| 'do' stmtlist			{ HsDo $2 }+>	| fexp				{ $1 }++> fexp :: { HsExp }+>	: fexp aexp			{ HsApp $1 $2 }+>  	| aexp				{ $1 }++> apats :: { [HsPat] }+>	: apats apat			{ $2 : $1 }+>  	| apat				{ [$1] }++> apat :: { HsPat }+>	: aexp				{% checkPattern $1 }++UGLY: Because patterns and expressions are mixed, aexp has to be split into+two rules: One right-recursive and one left-recursive. Otherwise we get two+reduce/reduce-errors (for as-patterns and irrefutable patters).++Even though the variable in an as-pattern cannot be qualified, we use+qvar here to avoid a shift/reduce conflict, and then check it ourselves+(as for vars above).++> aexp	:: { HsExp }+>	: qvar '@' aexp			{% do { n <- checkUnQual $1;+>						return (HsAsPat n $3) } }+>	| '~' aexp			{ HsIrrPat $2 }+>  	| aexp1				{ $1 }++Note: The first two alternatives of aexp1 are not necessarily record+updates: they could be labeled constructions.++> aexp1	:: { HsExp }+>  	: aexp1 '{' '}' 		{% mkRecConstrOrUpdate $1 [] }+>  	| aexp1 '{' fbinds '}' 		{% mkRecConstrOrUpdate $1 (reverse $3) }+>  	| aexp2				{ $1 }++According to the Report, the left section (e op) is legal iff (e op x)+parses equivalently to ((e) op x).  Thus e must be an exp0b.++> aexp2	:: { HsExp }+>	: qvar				{ HsVar $1 }+>	| gcon				{ $1 }+>  	| literal			{ HsLit $1 }+>	| '(' exp ')'			{ HsParen $2 }+>	| '(' texps ')'			{ HsTuple (reverse $2) }+>	| '[' list ']'                  { $2 }+>	| '(' exp0b qop ')'		{ HsLeftSection $2 $3  }+>	| '(' qopm exp0 ')'		{ HsRightSection $2 $3 }+>	| '_'				{ HsWildCard }++> commas :: { Int }+>	: commas ','			{ $1 + 1 }+>	| ','				{ 1 }++> texps :: { [HsExp] }+>	: texps ',' exp			{ $3 : $1 }+>	| exp ',' exp			{ [$3,$1] }++-----------------------------------------------------------------------------+List expressions++The rules below are little bit contorted to keep lexps left-recursive while+avoiding another shift/reduce-conflict.++> list :: { HsExp }+>	: exp				{ HsList [$1] }+>	| lexps 			{ HsList (reverse $1) }+>	| exp '..'			{ HsEnumFrom $1 }+>	| exp ',' exp '..' 		{ HsEnumFromThen $1 $3 }+>	| exp '..' exp	 		{ HsEnumFromTo $1 $3 }+>	| exp ',' exp '..' exp		{ HsEnumFromThenTo $1 $3 $5 }+>	| exp '|' quals			{ HsListComp $1 (reverse $3) }++> lexps :: { [HsExp] }+>	: lexps ',' exp 		{ $3 : $1 }+>	| exp ',' exp			{ [$3,$1] }++-----------------------------------------------------------------------------+List comprehensions++> quals :: { [HsStmt] }+>	: quals ',' qual		{ $3 : $1 }+>	| qual				{ [$1] }++> qual  :: { HsStmt }+>	: pat srcloc '<-' exp		{ HsGenerator $2 $1 $4 }+>	| exp				{ HsQualifier $1 }+>  	| 'let' decllist		{ HsLetStmt $2 }++-----------------------------------------------------------------------------+Case alternatives++> altslist :: { [HsAlt] }+>	: '{'  alts '}'			{ $2 }+>	| open alts close		{ $2 }++> alts :: { [HsAlt] }+>	: optsemis alts1 optsemis	{ reverse $2 }++> alts1 :: { [HsAlt] }+>	: alts1 semis alt		{ $3 : $1 }+>	| alt				{ [$1] }++> alt :: { HsAlt }+>	: srcloc pat ralt optwhere	{ HsAlt $1 $2 $3 $4 }++> ralt :: { HsGuardedAlts }+>	: '->' exp			{ HsUnGuardedAlt $2 }+>	| gdpats			{ HsGuardedAlts (reverse $1) }++> gdpats :: { [HsGuardedAlt] }+>	: gdpats gdpat			{ $2 : $1 }+>	| gdpat				{ [$1] }++> gdpat	:: { HsGuardedAlt }+>	: srcloc '|' exp0 '->' exp	{ HsGuardedAlt $1 $3 $5 }++> pat :: { HsPat }+>	: exp0b				{% checkPattern $1 }++-----------------------------------------------------------------------------+Statement sequences++As per the Report, but with stmt expanded to simplify building the list+without introducing conflicts.  This also ensures that the last stmt is+an expression.++> stmtlist :: { [HsStmt] }+>	: '{'  stmts '}'		{ $2 }+>	| open stmts close		{ $2 }++> stmts :: { [HsStmt] }+>	: 'let' decllist ';' stmts	{ HsLetStmt $2 : $4 }+>	| pat srcloc '<-' exp ';' stmts	{ HsGenerator $2 $1 $4 : $6 }+>	| exp ';' stmts			{ HsQualifier $1 : $3 }+>	| ';' stmts			{ $2 }+>	| exp ';'			{ [HsQualifier $1] }+>	| exp				{ [HsQualifier $1] }++-----------------------------------------------------------------------------+Record Field Update/Construction++> fbinds :: { [HsFieldUpdate] }+>	: fbinds ',' fbind		{ $3 : $1 }+>	| fbind				{ [$1] }++> fbind	:: { HsFieldUpdate }+>	: qvar '=' exp			{ HsFieldUpdate $1 $3 }++-----------------------------------------------------------------------------+Commands (for arrow expressions)+Largely analogous to the treatment of exp (qv), including the distinctions+exp0a/exp0b and exp10a/exp10b.++> cmd :: { ArrSyn.Cmd }+>	: exp0b '-<' exp		{ ArrSyn.Input $1 $3 }+>	| exp0b '-<<' exp		{ ArrSyn.Input $1 $3 }+>	| exp0b '>-' exp		{ ArrSyn.Input $3 $1 }+>	| exp0b '>>-' exp		{ ArrSyn.Input $3 $1 }+>	| cmd0				{ $1 }++> cmd0 :: { ArrSyn.Cmd }+>	: cmd0a				{ $1 }+>	| cmd0b				{ $1 }++> cmd0a :: { ArrSyn.Cmd }+>	: cmd0b qop cmd10a		{ ArrSyn.InfixOp $1 $2 $3 }+>	| cmd10a			{ $1 }++> cmd0b :: { ArrSyn.Cmd }+>	: cmd0b qop cmd10b		{ ArrSyn.InfixOp $1 $2 $3 }+>	| cmd10b			{ $1 }++> cmd10a :: { ArrSyn.Cmd }+>	: '\\' srcloc apats '->' cmd	{ ArrSyn.Kappa $2 (reverse $3) $5 }+>	| 'let' decllist 'in' cmd	{ ArrSyn.Let $2 $4 }+>	| 'let' cmddecl 'in' cmd	{ ArrSyn.LetCmd $2 $4 }+>	| 'if' exp 'then' cmd 'else' cmd { ArrSyn.If $2 $4 $6 }++> cmd10b :: { ArrSyn.Cmd }+>	: 'case' exp 'of' altslistA	{ ArrSyn.Case $2 $4 }+>	| 'do' stmtlistA		{ ArrSyn.Do (fst $2) (snd $2) }+>	| fcmd				{ $1 }++> fcmd :: { ArrSyn.Cmd }+>	: fcmd aexp			{ ArrSyn.App $1 $2 }+>	| acmd				{ $1 }++> acmd :: { ArrSyn.Cmd }+>	: '(' cmd ')'			{ ArrSyn.Paren $2 }+>	| '(|' aexp acmds '|)'		{ ArrSyn.Op $2 (reverse $3) }+>	| 'cmd' varid			{ ArrSyn.CmdVar $2 }++> acmds :: { [ArrSyn.Cmd] }+>	: acmds acmd			{ $2 : $1 }+>	| acmd				{ [$1] }++Case commands++> altslistA :: { [ArrSyn.Alt] }+>	: '{'  altsA '}'		{ $2 }+>	| open altsA close		{ $2 }++> altsA :: { [ArrSyn.Alt] }+>	: optsemis alts1A optsemis	{ reverse $2 }++> alts1A :: { [ArrSyn.Alt] }+>	: alts1A semis altA		{ $3 : $1 }+>	| altA				{ [$1] }++> altA :: { ArrSyn.Alt }+>	: srcloc pat raltA optwhere	{ ArrSyn.Alt $1 $2 $3 $4 }++> raltA :: { ArrSyn.GuardedAlts }+>	: '->' cmd			{ ArrSyn.UnGuardedAlt $2 }+>	| gdpatsA			{ ArrSyn.GuardedAlts (reverse $1) }++> gdpatsA :: { [ArrSyn.GuardedAlt] }+>	: gdpatsA gdpatA		{ $2 : $1 }+>	| gdpatA			{ [$1] }++> gdpatA :: { ArrSyn.GuardedAlt }+>	: srcloc '|' exp0 '->' cmd	{ ArrSyn.GuardedAlt $1 $3 $5 }++The arrow version of do statements++> stmtlistA :: { ArrSyn.Stmts }+>	: '{'  stmtsA '}'		{ $2 }+>	| open stmtsA close		{ $2 }++Note that stmts/stmtsA must be right-recursive; otherwise it is not+possible, in situations like++	'proc' pat '->' 'do' '(' 'let' decls . ';'++to choose between the productions++	qual -> 'let' decls+	qualA -> 'let' decls++Now that decision is delayed until the trailing exp/cmd is seen.++> stmtsA :: { ArrSyn.Stmts }+>	: squalA ';' stmtsA		{ ($1 : fst $3, snd $3) }+>	| cmd ';' stmtsA		{ (ArrSyn.Generator undefined HsPWildCard $1 : fst $3, snd $3) }+>	| 'let' decllist ';' stmtsA	{ (ArrSyn.LetStmt $2 : fst $4, snd $4) }+>	| ';' stmtsA			{ $2 }+>	| cmd ';'			{ ([], $1) }+>	| cmd				{ ([], $1) }++> squalA :: { ArrSyn.Stmt }+>	: pat srcloc '<-' cmd		{ ArrSyn.Generator $2 $1 $4 }+>	| cmd '->' srcloc pat		{ ArrSyn.Generator $3 $4 $1 }+>	| 'rec' defnsA			{ ArrSyn.RecStmt (reverse $2) }+>	| 'let' cmddecl			{ ArrSyn.LetCmdStmt $2 }++> cmddecl :: { ArrSyn.VarDecl ArrSyn.Cmd }+>	: srcloc 'cmd' varid '=' cmd	{ ArrSyn.VarDecl $1 $3 $5 }++> defnsA :: { [ArrSyn.Stmt] }+>	: '{'  stmts1A '}'		{ $2 }+>	| open stmts1A close		{ $2 }++> stmts1A :: { [ArrSyn.Stmt] }+>	: stmts1A ';' qualA		{ $3 : $1 }+>	| qualA				{ [$1] }++> qualA :: { ArrSyn.Stmt }+>	: squalA			{ $1 }+>	| 'let' decllist		{ ArrSyn.LetStmt $2 }++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++> gcon :: { HsExp }+>  	: '(' ')'		{ unit_con }+>	| '[' ']'		{ HsList [] }+>	| '(' commas ')'	{ tuple_con $2 }+>  	| qcon			{ HsCon $1 }++> var 	:: { HsName }+>	: varid			{ $1 }+>	| '(' varsym ')'	{ $2 }++> qvar 	:: { HsQName }+>	: qvarid		{ $1 }+>	| '(' qvarsym ')'	{ $2 }++> con	:: { HsName }+>	: conid			{ $1 }+>	| '(' consym ')'        { $2 }++> qcon	:: { HsQName }+>	: qconid		{ $1 }+>	| '(' gconsym ')'	{ $2 }++> varop	:: { HsName }+>	: varsym		{ $1 }+>	| '`' varid '`'		{ $2 }++> qvarop :: { HsQName }+>	: qvarsym		{ $1 }+>	| '`' qvarid '`'	{ $2 }++> qvaropm :: { HsQName }+>	: qvarsymm		{ $1 }+>	| '`' qvarid '`'	{ $2 }++> conop :: { HsName }+>	: consym		{ $1 }	+>	| '`' conid '`'		{ $2 }++> qconop :: { HsQName }+>	: gconsym		{ $1 }+>	| '`' qconid '`'	{ $2 }++> op	:: { HsOp }+>	: varop			{ HsVarOp $1 }+>	| conop 		{ HsConOp $1 }++> qop	:: { HsQOp }+>	: qvarop		{ HsQVarOp $1 }+>	| qconop		{ HsQConOp $1 }++> qopm	:: { HsQOp }+>	: qvaropm		{ HsQVarOp $1 }+>	| qconop		{ HsQConOp $1 }++> gconsym :: { HsQName }+>	: ':'			{ list_cons_name }+>	| qconsym		{ $1 }++-----------------------------------------------------------------------------+Identifiers and Symbols++> qvarid :: { HsQName }+>	: varid			{ UnQual $1 }+>	| QVARID		{ Qual (Module (fst $1)) (HsIdent (snd $1)) }++> varid :: { HsName }+>	: VARID			{ HsIdent $1 }+>	| 'as'			{ HsIdent "as" }+>	| 'export'		{ HsIdent "export" }+>	| 'hiding'		{ HsIdent "hiding" }+>	| 'qualified'		{ HsIdent "qualified" }+>	| 'safe'		{ HsIdent "safe" }+>	| 'unsafe'		{ HsIdent "unsafe" }++> qconid :: { HsQName }+>	: conid			{ UnQual $1 }+>	| QCONID		{ Qual (Module (fst $1)) (HsIdent (snd $1)) }++> conid :: { HsName }+>	: CONID			{ HsIdent $1 }++> qconsym :: { HsQName }+>	: consym		{ UnQual $1 }+>	| QCONSYM		{ Qual (Module (fst $1)) (HsSymbol (snd $1)) }++> consym :: { HsName }+>	: CONSYM		{ HsSymbol $1 }++> qvarsym :: { HsQName }+>	: varsym		{ UnQual $1 }+>	| qvarsym1		{ $1 }++> qvarsymm :: { HsQName }+>	: varsymm		{ UnQual $1 }+>	| qvarsym1		{ $1 }++> varsym :: { HsName }+>	: VARSYM		{ HsSymbol $1 }+>	| '-'			{ HsSymbol "-" }+>	| '!'			{ HsSymbol "!" }++> varsymm :: { HsName } -- varsym not including '-'+>	: VARSYM		{ HsSymbol $1 }+>	| '!'			{ HsSymbol "!" }++> qvarsym1 :: { HsQName }+>	: QVARSYM		{ Qual (Module (fst $1)) (HsSymbol (snd $1)) }++> literal :: { HsLiteral }+>	: INT			{ HsInt $1 }+>	| CHAR 			{ HsChar $1 }+>	| RATIONAL		{ HsFrac $1 }+>	| STRING		{ HsString $1 }++> srcloc :: { SrcLoc }	:	{% getSrcLoc }+ +-----------------------------------------------------------------------------+Layout++> open  :: { () }	:	{% pushCurrentContext }++> close :: { () }+>	: vccurly		{ () } -- context popped in lexer.+>	| error			{% popContext }++-----------------------------------------------------------------------------+Miscellaneous (mostly renamings)++> modid :: { Module }+>	: CONID			{ Module $1 }+>	| QCONID		{ Module (fst $1 ++ '.':snd $1) }++> tyconorcls :: { HsName }+>	: conid			{ $1 }++> tycon :: { HsName }+>	: conid			{ $1 }++> qtyconorcls :: { HsQName }+>	: qconid		{ $1 }++> qtycls :: { HsQName }+>	: qconid		{ $1 }++> tyvar :: { HsName }+>	: varid			{ $1 }++-----------------------------------------------------------------------------++> {+> happyError :: P a+> happyError = fail "Parse error"++> -- | Parse of a string, which should contain a complete Haskell 98 module.+> parseModule :: String -> ParseResult HsModule+> parseModule = runParser parse++> -- | Parse of a string, which should contain a complete Haskell 98 module.+> parseModuleWithMode :: ParseMode -> String -> ParseResult HsModule+> parseModuleWithMode mode = runParserWithMode mode parse+>+> parseProc :: String -> ParseResult HsExp+> parseProc = runParser parseProcExp+> }
+ src/State.hs view
@@ -0,0 +1,6 @@+-- A Haskell-98-compatible subset of the Control.Monad.State module.++module State(State, runState, get, put) where++import Control.Monad.Trans.State+
+ src/Utils.lhs view
@@ -0,0 +1,204 @@+Miscellaneous utilities on ordinary Haskell syntax used by the arrow+translator.++> module Utils(+>	FreeVars(freeVars), DefinedVars(definedVars),+>	failureFree, irrPat, paren, parenInfixArg,+>	tuple, tupleP,+>	times+> ) where++> import Data.Set (Set)+> import qualified Data.Set as Set+> import Language.Haskell.Syntax++The set of free variables in some construct.++> class FreeVars a where+>	freeVars :: a -> Set HsName++> instance FreeVars a => FreeVars [a] where+>	freeVars = Set.unions . map freeVars++> instance FreeVars HsPat where+>	freeVars (HsPVar n) = Set.singleton n+>	freeVars (HsPLit _) = Set.empty+>	freeVars (HsPNeg p) = freeVars p+>	freeVars (HsPInfixApp p1 _ p2) = freeVars p1 `Set.union` freeVars p2+>	freeVars (HsPApp _ ps) = freeVars ps+>	freeVars (HsPTuple ps) = freeVars ps+>	freeVars (HsPList ps) = freeVars ps+>	freeVars (HsPParen p) = freeVars p+>	freeVars (HsPRec _ pfs) = freeVars pfs+>	freeVars (HsPAsPat n p) = Set.insert n (freeVars p)+>	freeVars (HsPWildCard) = Set.empty+>	freeVars (HsPIrrPat p) = freeVars p++> instance FreeVars HsPatField where+>	freeVars (HsPFieldPat _ p) = freeVars p++> instance FreeVars HsFieldUpdate where+>	freeVars (HsFieldUpdate _ e) = freeVars e++> instance FreeVars HsExp where+>	freeVars (HsVar n) = freeVars n+>	freeVars (HsCon _) = Set.empty+>	freeVars (HsLit _) = Set.empty+>	freeVars (HsInfixApp e1 op e2) =+>		freeVars e1 `Set.union` freeVars op `Set.union` freeVars e2+>	freeVars (HsApp f e) = freeVars f `Set.union` freeVars e+>	freeVars (HsNegApp e) = freeVars e+>	freeVars (HsLambda _ ps e) = freeVars e `Set.difference` freeVars ps+>	freeVars (HsLet decls e) =+>		(freeVars decls `Set.union` freeVars e) `Set.difference`+>			definedVars decls+>	freeVars (HsIf e1 e2 e3) =+>		freeVars e1 `Set.union` freeVars e2 `Set.union` freeVars e3+>	freeVars (HsCase e as) = freeVars e `Set.union` freeVars as+>	freeVars (HsDo ss) = freeVarsStmts ss+>	freeVars (HsTuple es) = freeVars es+>	freeVars (HsList es) = freeVars es+>	freeVars (HsParen e) = freeVars e+>	freeVars (HsLeftSection e op) = freeVars e `Set.union` freeVars op+>	freeVars (HsRightSection op e) = freeVars op `Set.union` freeVars e+>	freeVars (HsRecConstr _ us) = freeVars us+>	freeVars (HsRecUpdate e us) = freeVars e `Set.union` freeVars us+>	freeVars (HsEnumFrom e) = freeVars e+>	freeVars (HsEnumFromTo e1 e2) = freeVars e1 `Set.union` freeVars e2+>	freeVars (HsEnumFromThen e1 e2) = freeVars e1 `Set.union` freeVars e2+>	freeVars (HsEnumFromThenTo e1 e2 e3) =+>		freeVars e1 `Set.union` freeVars e2 `Set.union` freeVars e3+>	freeVars (HsListComp e ss) =+>		freeVars e `Set.union` freeVarsStmts ss+>	freeVars (HsExpTypeSig _ e _) = freeVars e+>	freeVars (HsAsPat _ _) = error "freeVars (x @ p)"+>	freeVars (HsWildCard) = error "freeVars _"+>	freeVars (HsIrrPat _) = error "freeVars ~p"++> instance FreeVars HsQOp where+>	freeVars (HsQVarOp n) = freeVars n+>	freeVars (HsQConOp _) = Set.empty++> instance FreeVars HsQName where+>	freeVars (UnQual v) = Set.singleton v+>	freeVars _ = Set.empty++> instance FreeVars HsAlt where+>	freeVars (HsAlt _ p gas decls) =+>		(freeVars gas `Set.union` freeVars decls) `Set.difference`+>		(freeVars p `Set.union` definedVars decls)++> instance FreeVars HsGuardedAlts where+>	freeVars (HsUnGuardedAlt e) = freeVars e+>	freeVars (HsGuardedAlts alts) = freeVars alts++> instance FreeVars HsGuardedAlt where+>	freeVars (HsGuardedAlt _ e1 e2) = freeVars e1 `Set.union` freeVars e2++> instance FreeVars HsDecl where+>	freeVars (HsFunBind ms) = freeVars ms+>	freeVars (HsPatBind _ p rhs decls) =+>		(freeVars rhs `Set.union` freeVars decls) `Set.difference`+>		(freeVars p `Set.union` definedVars decls)+>	freeVars _ = Set.empty++> instance FreeVars HsMatch where+>	freeVars (HsMatch _ n ps rhs decls) =+>		(freeVars rhs `Set.union` freeVars decls) `Set.difference`+>		(Set.insert n (freeVars ps) `Set.union` definedVars decls)++> instance FreeVars HsRhs where+>	freeVars (HsUnGuardedRhs e) = freeVars e+>	freeVars (HsGuardedRhss grs) = freeVars grs++> instance FreeVars HsGuardedRhs where+>	freeVars (HsGuardedRhs _ e1 e2) = freeVars e1 `Set.union` freeVars e2++> freeVarsStmts :: [HsStmt] -> Set HsName+> freeVarsStmts = foldr addStmt Set.empty+>	where	addStmt (HsGenerator _ p e) s =+>			freeVars e `Set.union` (s `Set.difference` freeVars p)+>		addStmt (HsQualifier e) _s = freeVars e+>		addStmt (HsLetStmt decls) s =+>			(freeVars decls `Set.union` s) `Set.difference` definedVars decls++The set of variables defined by a construct.++> class DefinedVars a where+>	definedVars :: a -> Set HsName++> instance DefinedVars a => DefinedVars [a] where+>	definedVars = Set.unions . map definedVars++> instance DefinedVars HsDecl where+>	definedVars (HsFunBind (HsMatch _ n _ _ _:_)) = Set.singleton n+>	definedVars (HsPatBind _ p _ _) = freeVars p+>	definedVars _ = Set.empty++Is the pattern failure-free?+(This is incomplete at the moment, because patterns made with unique+constructors should be failure-free, but we have no way of detecting them.)++> failureFree :: HsPat -> Bool+> failureFree (HsPVar _) = True+> failureFree (HsPApp n ps) = n == unit_con_name && null ps+> failureFree (HsPTuple ps) = all failureFree ps+> failureFree (HsPParen p) = failureFree p+> failureFree (HsPAsPat _ p) = failureFree p+> failureFree (HsPWildCard) = True+> failureFree (HsPIrrPat _) = True+> failureFree _ = False++Irrefutable version of a pattern++> irrPat :: HsPat -> HsPat+> irrPat p@(HsPVar _) = p+> irrPat (HsPParen p) = HsPParen (irrPat p)+> irrPat (HsPAsPat n p) = HsPAsPat n (irrPat p)+> irrPat p@(HsPWildCard) = p+> irrPat p@(HsPIrrPat _) = p+> irrPat p = HsPIrrPat p++Make an expression into an aexp, by adding parentheses if required.++> paren :: HsExp -> HsExp+> paren e = if isAexp e then e else HsParen e+>	where	isAexp (HsVar _) = True+>		isAexp (HsCon _) = True+>		isAexp (HsLit _) = True+>		isAexp (HsParen _) = True+>		isAexp (HsTuple _) = True+>		isAexp (HsList _) = True+>		isAexp (HsEnumFrom _) = True+>		isAexp (HsEnumFromTo _ _) = True+>		isAexp (HsEnumFromThen _ _) = True+>		isAexp (HsEnumFromThenTo _ _ _) = True+>		isAexp (HsListComp _ _) = True+>		isAexp (HsLeftSection _ _) = True+>		isAexp (HsRightSection _ _) = True+>		isAexp (HsRecConstr _ _) = True+>		isAexp (HsRecUpdate _ _) = True+>		isAexp _ = False++Make an expression into an fexp, by adding parentheses if required.++> parenInfixArg :: HsExp -> HsExp+> parenInfixArg e@(HsApp _ _) = e+> parenInfixArg e = paren e++Tuples++> tuple :: [HsExp] -> HsExp+> tuple [] = unit_con+> tuple [e] = e+> tuple es = HsTuple es++> tupleP :: [HsPat] -> HsPat+> tupleP [] = HsPApp unit_con_name []+> tupleP [e] = e+> tupleP es = HsPTuple es++Compose a function n times.++> times :: Int -> (a -> a) -> a -> a+> times n f a = foldr ($) a (replicate n f)