diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,15 @@ +A prototype quasiquoter for arrow notation packaged by Jose Iborra, +based on the arrowp preprocessor developed by Ross Paterson . + +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 |] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/arrowp-qq.cabal b/arrowp-qq.cabal new file mode 100644 --- /dev/null +++ b/arrowp-qq.cabal @@ -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 +Maintainer: Jose Iborra +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 diff --git a/src/ArrCode.lhs b/src/ArrCode.lhs new file mode 100644 --- /dev/null +++ b/src/ArrCode.lhs @@ -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) + diff --git a/src/ArrSyn.lhs b/src/ArrSyn.lhs new file mode 100644 --- /dev/null +++ b/src/ArrSyn.lhs @@ -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) diff --git a/src/Control/Arrow/QuasiQuoter.hs b/src/Control/Arrow/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/QuasiQuoter.hs @@ -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 diff --git a/src/Lexer.hs b/src/Lexer.hs new file mode 100644 --- /dev/null +++ b/src/Lexer.hs @@ -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) diff --git a/src/Parser.ly b/src/Parser.ly new file mode 100644 --- /dev/null +++ b/src/Parser.ly @@ -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 +> } diff --git a/src/State.hs b/src/State.hs new file mode 100644 --- /dev/null +++ b/src/State.hs @@ -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 + diff --git a/src/Utils.lhs b/src/Utils.lhs new file mode 100644 --- /dev/null +++ b/src/Utils.lhs @@ -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)