diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,15 +0,0 @@ -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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,101 @@ +[![Hackage](https://img.shields.io/hackage/v/arrowp-qq.svg)](https://hackage.haskell.org/package/arrowp-qq) +[![Stackage Nightly](http://stackage.org/package/arrowp-qq/badge/nightly)](http://stackage.org/nightly/package/arrowp-qq) +[![Travis Build Status](https://travis-ci.org/pepeiborra/arrowp-qq.svg)](https://travis-ci.org/pepeiborra/arrowp-qq) + +Arrowp-qq +========== +A preprocessor for arrow notation packaged by Jose Iborra, +based on the arrowp preprocessor developed by Ross Paterson . + +Notable features include support for GHC Haskell syntax and a +quasiquoter that can be used instead of the preprocessor. + +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. + +Status +------ + +The parser cannot handle banana brackets for +control operators in arrow notation (the **proc** keyword in the original paper), +due to a +[limitation](https://github.com/haskell-suite/haskell-src-exts/issues/45) +in haskell-src-exts. In order to use banana brackets, the recommendation +is to fall back to the GHC Arrows parser. + +Support for GHC Haskell notation inside arrow blocks is not complete, e.g. +multi-way-if and lambda case are unlikely to work as expected. If you run into +one of these, please open an issue or vote for an existing one, as I plan to extend +the support on demand. + +Using the `proc` 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 |] +``` + +Using the **arrowp-ext** preprocessor +--------------------------------- + +``` +{-# OPTIONS -F -pgmF arrowp-ext #-} +``` + +Comparison with **arrowp** +----------------------- +**arrowp-qq** extends the original **arrowp** in three dimensions: +1. It replaces the `haskell-src` based parser with one based on `haskell-src-exts`, which handles most of GHC 8.0.2 Haskell syntax. +2. It provides not only a preprocessor but also a quasiquoter, which is a better option in certain cases. +3. It extends the desugaring to handle static conditional expressions (currently only if-then-else). Example: +``` +proc inputs -> do + results <- processor -< inputs + if outputResultsArg + then outputSink -< results + else returnA -< () + returnA -< results +``` +The standard **arrowp** (and GHC) desugaring for this code is: +``` + = ((processor >>> arr (\ results -> (results, results))) >>> + (first + (arr + (\ results -> if outputResultsArg then Left results else Right ()) + >>> (outputSink ||| returnA)) + >>> arr (\ (_, results) -> results))) +``` +This requires an `ArrowChoice`, but there is a more efficient desugaring which +performs the choice at compile time and thus an `Arrow` suffices: +``` +((processor >>> arr (\ results -> (results, results))) >>> + (first + (if outputResultsArg then outputSink else arr (\ results -> ())) + >>> arr (\ (_, results) -> results))) +``` + +Comparison with **GHC** +----------------------- +The GHC desugarer does not do a very good job of minimizing the number of +`first` calls inserted. In certain `Arrow` instances, this can have a material effect +on performance. Example: +``` +trivial = proc inputs -> do + chunked <- chunk -< inputs + results <- process -< chunked + returnA -< results +``` +This code ought to desugar to a chain of arrows, and indeed, both arrowp and +arrowp-qq desugar this to: +``` +trivial = chunk >>> process +``` +However GHC will produce (approximately) the following code: +``` + arr(\inputs -> (inputs,inputs)) >>> first chunk >>> first process >>> arr fst +``` diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE RecordWildCards #-} +module Main where + +import Control.Arrow.Notation +import Data.List +import Debug.Hoed.Pure +import Language.Haskell.Exts +import System.Environment +import System.Exit +import System.IO +import Text.Printf + +usage :: String -> String +usage progName = unlines [ + "usage: " ++ progName ++ + " [FILENAME] [SOURCE] [DEST]", + "Read arrow notation from SOURCE (derived from FILENAME) and write", + "standard Haskell to DEST.", + "If no FILENAME, use SOURCE as the original name.", + "If no DEST or if DEST is `-', write to standard output.", + "If no SOURCE or if SOURCE is `-', read standard input." + ] + +main :: IO () +main = runO $ do + args <- getArgs + progName <- getProgName + (orig, inp, out) <- case args of + ["--help"] -> do + putStrLn $ usage progName + exitSuccess + [] -> return ("input",Nothing,Nothing) + [i] -> return (i, Just i, Nothing) + [i,o] -> return (i, Just i, Just o) + [orig,i,o] -> return (orig, Just i, Just o) + _ -> do + putStrLn $ usage progName + error "Unrecognized set of command line arguments" + hIn <- maybe (return stdin) (`openFile` ReadMode) inp + hOut <- maybe (return stdout) (`openFile` WriteMode) out + contents <- hGetContents hIn + case parseFileContentsWithExts defaultExtensions contents of + ParseFailed SrcLoc{..} err -> do + printf "Parse error at %s:%d:%d: %s" orig srcLine srcColumn err + exitFailure + ParseOk x -> do + let x' = translateModule x + hPutStr hOut $ prettyPrintWithMode defaultMode{linePragmas=True} x' + hClose hOut + +defaultExtensions :: [Extension] +defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions + +badExtensions :: [KnownExtension] +badExtensions = + [TransformListComp -- steals the group keyword + ,XmlSyntax, RegularPatterns -- steals a-b + ,UnboxedTuples -- breaks (#) lens operator + ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + ,DoRec, RecursiveDo -- breaks rec + ,TypeApplications -- HSE fails on @ patterns + ] diff --git a/arrowp-qq.cabal b/arrowp-qq.cabal --- a/arrowp-qq.cabal +++ b/arrowp-qq.cabal @@ -1,24 +1,100 @@ Name: arrowp-qq -Version: 0.1.1 +Version: 0.2 Cabal-Version: >= 1.20 Build-Type: Simple License: GPL License-File: LICENCE Author: Jose Iborra Maintainer: Jose Iborra -Homepage: http://www.haskell.org/arrows/ +Homepage: https://github.com/pepeiborra/arrowp Category: Development -Synopsis: quasiquoter translating arrow notation into Haskell 98 -Description: A quasiquoter built on top of the arrowp package. -Extra-Source-Files: README +Synopsis: A preprocessor and quasiquoter for translating arrow notation +Description: A suite of preprocessor and quasiquoter to desugar arrow notation built on top of Ross Paterson's arrowp and the venerable haskell-src-exts. +Extra-Source-Files: README.md +Flag Debug + Description: Enabled Hoed algorithmic debugging + Default: False + Manual: True + +Flag TestExamples + Description: Build the examples using the preprocessor and quasiquoter + Default: False + Manual: True + +Source-Repository head + Type: git + Location: http://github.com/pepeiborra/arrowp + Library - Exposed-Modules: Control.Arrow.QuasiQuoter - Build-Depends: base < 5, array, containers, haskell-src, template-haskell < 2.13, transformers + Exposed-Modules: + Control.Arrow.Notation, + Control.Arrow.QuasiQuoter + Build-Depends: base < 5, + array, + containers, + data-default, + haskell-src-exts, + haskell-src-exts-util, + haskell-src-meta, + syb, + template-haskell < 2.13, + transformers, + uniplate + if flag(Debug) + Build-Depends: Hoed, haskell-src-exts-observe + cpp-options: -DDEBUG + else + Build-Depends: NoHoed + Hs-Source-Dirs: src - Other-Modules: ArrCode ArrSyn Lexer Parser Parser State Utils + Other-Modules: ArrCode ArrSyn Utils Default-Language: Haskell2010 -Source-Repository head - Type: darcs - Location: http://github.com/pepeiborra/arrowp +executable arrowp-ext + buildable: True + main-is: Main.hs + hs-source-dirs: + app + build-depends: + base >= 4.7 && < 5, + arrowp-qq, + haskell-src-exts + if flag(Debug) + Build-Depends: Hoed + cpp-options: -DDEBUG + else + Build-Depends: NoHoed + + default-language: Haskell2010 + +test-suite examples + if flag(TestExamples) + buildable: True + else + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: + examples, + examples/cgi, + examples/circuits, + examples/Parser, + examples/powertrees, + examples/small + main-is: Main.hs + other-modules: + Parser, + ExprParser, + BackStateArrow, + Conditional, + ListOps, + Egs, + Eval, + Eval1, + Lift, + ListOps, + TH.TH, + TH.While, + TH.BackStateArrow + build-depends: + base, arrows, arrowp-qq, template-haskell diff --git a/examples/Conditional.hs b/examples/Conditional.hs new file mode 100644 --- /dev/null +++ b/examples/Conditional.hs @@ -0,0 +1,21 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} + +module Conditional where + +import Control.Arrow + +-- An Arrow command for use with banana brackets? +static :: Arrow a => Bool -> a b c -> a b d -> a (c,d) c -> a b c +static use abc abd adc = proc b -> do + c <- abc -< b + res <- if use -- :: a (b,c) c + then do -- :: a (b,c) c + d <- abd -< b + adc -< (c,d) + else returnA -< c -- :: a (b,c) c + returnA -< res + +simple :: Bool -> a b c -> a b c +simple use abc = proc b -> do + if use then abc -< b else abc -< b diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,20 @@ +module Main where + +import BackstateArrow () +import CGI () +-- import Circuits () -- Uses banana brackets +import Conditional () +import Egs () +import Eval () +import Eval1 () +import ExprParser () +import Hom () +import Lift () +import ListOps () +import TH.TH () +import TH.BackstateArrow () +import TH.While () + + +main :: IO () +main = return () diff --git a/examples/Parser/ExprParser.lhs b/examples/Parser/ExprParser.lhs new file mode 100644 --- /dev/null +++ b/examples/Parser/ExprParser.lhs @@ -0,0 +1,91 @@ +> {-# OPTIONS -F -pgmF arrowp-ext #-} +> module ExprParser where + +> import Data.Char + +> import Control.Arrow +> import Control.Arrow.Transformer.Error + +> import Parser + +Expressions + +> data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown | EOF +> deriving (Show, Eq, Ord) + +> instance Symbol ESym where +> eof = EOF + +> type ExprParser = Parser ESym String (->) +> type ExprSym = Sym ESym String + +The grammar + +> expr :: ExprParser () Int +> expr = proc () -> do +> x <- term -< () +> expr' -< x + +> expr' :: ExprParser Int Int +> expr' = proc x -> do +> returnA -< x +> <+> do +> symbol Plus -< () +> y <- term -< () +> expr' -< x + y +> <+> do +> symbol Minus -< () +> y <- term -< () +> expr' -< x - y + +> term :: ExprParser () Int +> term = proc () -> do +> x <- factor -< () +> term' -< x + +> term' :: ExprParser Int Int +> term' = proc x -> do +> returnA -< x +> <+> do +> symbol Mult -< () +> y <- factor -< () +> term' -< x * y +> <+> do +> symbol Div -< () +> y <- factor -< () +> term' -< x `div` y + +> factor :: ExprParser () Int +> factor = proc () -> do +> v <- symbol Number -< () +> returnA -< read v::Int +> <+> do +> symbol Minus -< () +> v <- factor -< () +> returnA -< -v +> <+> do +> symbol LPar -< () +> v <- expr -< () +> symbol RPar -< () +> returnA -< v + +Lexical analysis + +> lexer :: String -> [ExprSym] +> lexer [] = [] +> lexer ('(':cs) = Sym LPar "(":lexer cs +> lexer (')':cs) = Sym RPar ")":lexer cs +> lexer ('+':cs) = Sym Plus "+":lexer cs +> lexer ('-':cs) = Sym Minus "-":lexer cs +> lexer ('*':cs) = Sym Mult "*":lexer cs +> lexer ('/':cs) = Sym Div "/":lexer cs +> lexer (c:cs) +> | isSpace c = lexer cs +> | isDigit c = Sym Number (c:w):lexer cs' +> | otherwise = Sym Unknown [c]:lexer cs +> where (w,cs') = span isDigit cs + +> run parser = runError (runParser parser) +> (\(_, err) -> error ("parse error: " ++ err)) . lexer + +> t = run expr diff --git a/examples/Parser/Parser.lhs b/examples/Parser/Parser.lhs new file mode 100644 --- /dev/null +++ b/examples/Parser/Parser.lhs @@ -0,0 +1,254 @@ +> {-# OPTIONS -F -pgmF arrowp-ext #-} + +LL(1) parser combinators: an arrow-ized (and greatly cut-down) version +of those of "Deterministic, Error-Correcting Combinator Parsers", by +Swierstra and Duponcheel. This version uses statically constructed +parse tables, but doesn't do error correction. + +> module Parser( +> Symbol(eof), Sym(Sym), +> Parser, symbol, runParser +> ) where + +> import Control.Arrow +> import Control.Arrow.Operations +> import Control.Arrow.Transformer +> import Control.Arrow.Transformer.Error +> import Control.Arrow.Transformer.State +> import Control.Arrow.Transformer.Static +> import Control.Category +> import Prelude hiding (id, (.)) + +We require a symbol for EOF, distinguished from all existing symbols: + +> class (Ord s, Show s) => Symbol s where +> eof :: s + +Combine a token with other information + +> data Sym s v = Sym s v + +> token (Sym s _) = s +> value (Sym _ v) = v + +> instance (Show s, Show v) => Show (Sym s v) where +> showsPrec p (Sym s v) = showParen True +> (shows s . showString ", " . shows v) + +> eofSym :: Symbol s => Sym s v +> eofSym = Sym s (error (show s ++ " has no value")) +> where s = eof + +A dynamic parser may fail or transform a list of symbols. + +> type DynamicParser s v a = StateArrow [Sym s v] (ErrorArrow String a) + +> liftDynamic :: ArrowChoice a => a b c -> DynamicParser s v a b c +> liftDynamic f = lift (lift f) + +The auxilliary definitions fetchHead and advance, with their explicit +type signatures, are needed to avoid nasty type errors. + +> fetchHead :: ArrowChoice a => DynamicParser s v a b (Sym s v) +> fetchHead = proc _ -> do +> (s:_) <- fetch -< () +> returnA -< s + +> getToken :: ArrowChoice a => DynamicParser s v a b s +> getToken = fetchHead >>> arr token + +> advance :: ArrowChoice a => DynamicParser s v a b (Sym s v) +> advance = proc _ -> do +> (s:ss) <- fetch -< () +> store -< ss +> returnA -< s + +The dynamic symbol parser ignores the symbol, as it will already have +been checked by the table lookup. + +> unitDP :: ArrowChoice a => DynamicParser s v a b v +> unitDP = advance >>> arr value + +Use the static information to construct a dynamic parser. + +If the table is empty, we know statically that any lookup will fail. + +> mkDynamic :: (Symbol s, ArrowChoice a) => +> Maybe (a b c) -> Table s (DynamicParser s v a b c) -> +> DynamicParser s v a b c +> mkDynamic Nothing t = arr id &&& getToken >>> lookupTable t err +> where err = proc _ -> raise -< "expected " ++ show (keys t) +> mkDynamic (Just f) t +> | isEmptyTable t = liftDynamic f +> | otherwise = arr id &&& getToken >>> lookupTable t base +> where base = proc (b, _) -> liftDynamic f -< b + +If a parser arrow can recognize the empty string, it needs a function +to transform input to output. + +> data Parser s v a b c = SP { +> emptyP :: StaticMonadArrow Maybe a b c, +> table :: Table s (DynamicParser s v a b c), +> dynamic :: DynamicParser s v a b c +> -- dynamic = mkDynamic empty table +> } + +> mkParser :: (Symbol s, ArrowChoice a) => +> StaticMonadArrow Maybe a b c -> Table s (DynamicParser s v a b c) -> +> Parser s v a b c +> mkParser e t = SP { +> emptyP = e, +> table = t, +> dynamic = mkDynamic (unwrapM e) t +> } + +> symbol :: (Symbol s, ArrowChoice a) => s -> Parser s v a b v +> symbol s = mkParser (wrapM Nothing) (unitTable s unitDP) + +> eofParser :: (Symbol s, ArrowChoice a) => Parser s v a b b +> eofParser = proc x -> do +> symbol eof -< () +> returnA -< x + +> instance (Symbol s, ArrowChoice a) => Arrow (Parser s v a) where +> arr f = mkParser (arr f) emptyTable +> first (SP{emptyP = e, table = t}) = +> mkParser (first e) (fmap first t) + +> instance (Symbol s, ArrowChoice a) => Category (Parser s v a) where +> id = arr id +> ~SP{emptyP = e2, table = t2, dynamic = d2} . SP{emptyP = e1, table = t1} = +> if isEmptyTable common +> then mkParser (e1 >>> e2) (plusTable t1' t2') +> else error ("parse conflict (concatenation) on " ++ +> show (keys common)) +> where common = intersectTable t1' t2' +> t1' = fmap (>>> d2) t1 +> t2' = seqEmptyTable (unwrapM e1) t2 +> seqEmptyTable Nothing _ = emptyTable +> seqEmptyTable (Just f) t = fmap (liftDynamic f >>>) t + +> instance (Symbol s, ArrowChoice a) => ArrowZero (Parser s v a) where +> zeroArrow = mkParser (wrapM Nothing) emptyTable + +> instance (Symbol s, ArrowChoice a) => ArrowPlus (Parser s v a) where +> SP{emptyP = e1, table = t1} <+> SP{emptyP = e2, table = t2} = +> if isEmptyTable common +> then mkParser (wrapM (plusEmpty (unwrapM e1) (unwrapM e2))) +> (plusTable t1 t2) +> else error ("parse conflict (union) on " ++ show (keys common)) +> where common = intersectTable t1 t2 +> plusEmpty Nothing e2 = e2 +> plusEmpty e1 Nothing = e1 +> plusEmpty _ _ = error "Empty-Empty" + +> instance (Symbol s, ArrowChoice a, ArrowLoop a) => +> ArrowLoop (Parser s v a) where +> loop (SP{emptyP = e, table = t}) = +> mkParser (wrapM (fmap loop (unwrapM e))) (fmap loop t) + +Run a parser on a complete input + +> runParser :: (Symbol s, ArrowChoice a) => +> Parser s v a () b -> ErrorArrow String a [Sym s v] b +> runParser p = proc ss -> do +> (v, _) <- rp -< ((), ss ++ [eofSym]) +> returnA -< v +> where rp = runState (dynamic (p >>> eofParser)) + +general combinators + +> option :: ArrowPlus a => (b -> c) -> a b c -> a b c +> option f p = arr f <+> p + +> many :: ArrowPlus a => a b c -> a b [c] +> many p = option (const []) (some p) + +> some :: ArrowPlus a => a b c -> a b [c] +> some p = some_p +> where some_p = proc b -> do +> c <- p -< b +> cs <- many_p -< b +> returnA -< c:cs +> many_p = option (const []) (some_p) + +A different design: + +> optional :: ArrowPlus a => a b b -> a b b +> optional p = arr id <+> p + +> star :: ArrowPlus a => a b b -> a b b +> star p = p' where p' = optional (p >>> p') + +> plus :: ArrowPlus a => a b b -> a b b +> plus p = p' where p' = p >>> optional p' + +Tables. + +During parser construction, these are represented as lists of pairs, +ordered by the key. Then these are transformed into balanced search +trees for use in parsing. + +> newtype Table k v = Table [(k, v)] + +> emptyTable :: Table k v +> emptyTable = Table [] + +> unitTable :: k -> v -> Table k v +> unitTable k v = Table [(k, v)] + +> instance Functor (Table k) where +> fmap f (Table kvs) = Table [(k, f v) | (k, v) <- kvs] + +Combine two tables. In case of conflicts, the first takes precedence. + +> plusTable :: Ord k => Table k v -> Table k v -> Table k v +> plusTable (Table t1) (Table t2) = Table (merge t1 t2) +> where merge [] kvs2 = kvs2 +> merge kvs1 [] = kvs1 +> merge (kvs1@(p1@(k1, _):kvs1')) (kvs2@(p2@(k2, _):kvs2')) = +> case compare k1 k2 of +> LT -> p1:merge kvs1' kvs2 +> EQ -> p1:merge kvs1' kvs2' +> GT -> p2:merge kvs1 kvs2' + +> intersectTable :: Ord k => Table k v1 -> Table k v2 -> Table k (v1, v2) +> intersectTable (Table t1) (Table t2) = Table (merge t1 t2) +> where merge [] _ = [] +> merge _ [] = [] +> merge (kvs1@((k1, v1):kvs1')) (kvs2@((k2, v2):kvs2')) = +> case compare k1 k2 of +> LT -> merge kvs1' kvs2 +> EQ -> (k1, (v1, v2)):merge kvs1' kvs2' +> GT -> merge kvs1 kvs2' + +> isEmptyTable :: Table k v -> Bool +> isEmptyTable (Table t) = null t + +> keys :: Table k v -> [k] +> keys (Table kvs) = map fst kvs + +> data SearchTree k v = Empty | Node (SearchTree k v) k v (SearchTree k v) + +Make a balanced search tree from a table + +> searchTree :: Ord k => Table k v -> SearchTree k v +> searchTree (Table kvs) = fst (mkTree (length kvs) kvs) +> where mkTree :: Int -> [(k,v)] -> (SearchTree k v, [(k,v)]) +> mkTree n kvs = if n == 0 then (Empty, kvs) +> else let size_l = (n-1) `div` 2 +> (l, (k, v):kvs') = mkTree size_l kvs +> (r, kvs'') = mkTree (n-1-size_l) kvs' +> in (Node l k v r, kvs'') + +Construct an arrow that searches for dynamic inputs in the statically +constructed tree of arrows. + +> lookupTable :: (ArrowChoice a, Ord k) => +> Table k (a b c) -> a (b, k) c -> a (b, k) c +> lookupTable t def = look (searchTree t) +> where look Empty = def +> look (Node l k a r) = proc (v, x) -> case compare x k of +> LT -> look l -< (v, x) +> EQ -> a -< v +> GT -> look r -< (v, x) diff --git a/examples/TH/BackStateArrow.hs b/examples/TH/BackStateArrow.hs new file mode 100644 --- /dev/null +++ b/examples/TH/BackStateArrow.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE QuasiQuotes #-} +module TH.BackstateArrow where + +import Control.Arrow +import Control.Arrow.QuasiQuoter +import Control.Category +import Prelude hiding (id, (.)) + +-- Generalizing the backwards state transformer monad mentioned +-- in Wadler's "The Essence of Functional Programming" + +newtype BackStateArrow s a b c = BST (a (b,s) (c,s)) + +instance ArrowLoop a => Category (BackStateArrow s a) where + BST g . BST f = BST $ [proc| (b, s) -> do + rec (c, s'') <- f -< (b, s') + (d, s') <- g -< (c, s) + returnA -< (d, s'')|] + +instance ArrowLoop a => Arrow (BackStateArrow s a) where + arr f = BST [proc| (b, s) -> + returnA -< (f b, s)|] + first (BST f) = BST $ [proc| ((b, d), s) -> do + (c, s') <- f -< (b, s) + returnA -< ((c, d), s')|] + +instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where + left (BST f) = BST $ [proc| (x, s) -> + case x of + Left b -> do + (c, s') <- f -< (b, s) + returnA -< (Left c, s') + Right d -> + returnA -< (Right d, s) |] + +instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where + loop (BST f) = BST $ [proc| (b, s) -> do + rec ((c, d), s') <- f -< ((b, d), s) + returnA -< (c, s') |] diff --git a/examples/TH/TH.hs b/examples/TH/TH.hs new file mode 100644 --- /dev/null +++ b/examples/TH/TH.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE QuasiQuotes #-} +module TH.TH where +import Control.Arrow +import Control.Arrow.QuasiQuoter +import Language.Haskell.TH + +while :: ArrowChoice a => a b Bool -> a b () -> a b () +while p s = proc x -> do + b <- p -< x + if b then do + s -< x + while p s -< x + else + returnA -< () + +test p s = [proc| x -> do + b <- p -< x + if b then do + s -< x + while p s -< x + else + returnA -< () + |] diff --git a/examples/TH/While.hs b/examples/TH/While.hs new file mode 100644 --- /dev/null +++ b/examples/TH/While.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE QuasiQuotes #-} +module TH.While where + +import Control.Arrow +import Control.Arrow.QuasiQuoter + +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 |] + +while :: ArrowChoice a => a b Bool -> a b () -> a b () +while p s = [proc| x -> do + b <- p -< x + if b then do + s -< x + while p s -< x + else + returnA -< () + |] diff --git a/examples/small/BackStateArrow.hs b/examples/small/BackStateArrow.hs new file mode 100644 --- /dev/null +++ b/examples/small/BackStateArrow.hs @@ -0,0 +1,39 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} +module BackstateArrow where + +import Control.Arrow +import Control.Category +import Prelude hiding (id, (.)) + +-- Generalizing the backwards state transformer monad mentioned +-- in Wadler's "The Essence of Functional Programming" + +newtype BackStateArrow s a b c = BST (a (b,s) (c,s)) + +instance ArrowLoop a => Category (BackStateArrow s a) where + BST g . BST f = BST $ proc (b, s) -> do + rec (c, s'') <- f -< (b, s') + (d, s') <- g -< (c, s) + returnA -< (d, s'') + +instance ArrowLoop a => Arrow (BackStateArrow s a) where + arr f = BST $ proc (b, s) -> + returnA -< (f b, s) + first (BST f) = BST $ proc ((b, d), s) -> do + (c, s') <- f -< (b, s) + returnA -< ((c, d), s') + +instance (ArrowLoop a, ArrowChoice a) => ArrowChoice (BackStateArrow s a) where + left (BST f) = BST $ proc (x, s) -> + case x of + Left b -> do + (c, s') <- f -< (b, s) + returnA -< (Left c, s') + Right d -> + returnA -< (Right d, s) + +instance ArrowLoop a => ArrowLoop (BackStateArrow s a) where + loop (BST f) = BST $ proc (b, s) -> do + rec ((c, d), s') <- f -< ((b, d), s) + returnA -< (c, s') diff --git a/examples/small/Egs.hs b/examples/small/Egs.hs new file mode 100644 --- /dev/null +++ b/examples/small/Egs.hs @@ -0,0 +1,20 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} +module Egs where + +import Control.Arrow + +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 + +while :: ArrowChoice a => a b Bool -> a b () -> a b () +while p s = proc x -> do + b <- p -< x + if b then do + s -< x + while p s -< x + else + returnA -< () diff --git a/examples/small/Eval.hs b/examples/small/Eval.hs new file mode 100644 --- /dev/null +++ b/examples/small/Eval.hs @@ -0,0 +1,42 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} +module Eval where + +-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5) + +import Control.Arrow +import Data.Maybe (fromJust) + +type Id = String +data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a)) +data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp + +eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a) +eval (Var s) = proc env -> + returnA -< fromJust (lookup s env) +eval (Add e1 e2) = proc env -> do + ~(Num u) <- eval e1 -< env + ~(Num v) <- eval e2 -< env + returnA -< Num (u + v) +eval (If e1 e2 e3) = proc env -> do + ~(Bl b) <- eval e1 -< env + if b then eval e2 -< env + else eval e3 -< env +eval (Lam x e) = proc env -> + returnA -< Fun (proc v -> eval e -< (x,v):env) +eval (App e1 e2) = proc env -> do + ~(Fun f) <- eval e1 -< env + v <- eval e2 -<< env + f -< v + +-- some tests + +i = Lam "x" (Var "x") +k = Lam "x" (Lam "y" (Var "x")) +double = Lam "x" (Add (Var "x") (Var "x")) + +t = n + where Num n = eval (If (Var "b") + (App (App k (App double (Var "x"))) (Var "x")) + (Add (Var "x") (Add (Var "x") (Var "x")))) + [("b", Bl True), ("x", Num 5)] diff --git a/examples/small/Eval1.hs b/examples/small/Eval1.hs new file mode 100644 --- /dev/null +++ b/examples/small/Eval1.hs @@ -0,0 +1,45 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} +module Eval1 where + +-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5) + +import Control.Arrow +import Data.Maybe (fromJust) + +type Id = String +data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a)) +data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp + +eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a) +eval (Var s) = proc env -> + returnA -< fromJust (lookup s env) +eval (Add e1 e2) = proc env -> + (eval e1 -< env) `bind` \ ~(Num u) -> + (eval e2 -< env) `bind` \ ~(Num v) -> + returnA -< Num (u + v) +eval (If e1 e2 e3) = proc env -> + (eval e1 -< env) `bind` \ ~(Bl b) -> + if b then eval e2 -< env + else eval e3 -< env +eval (Lam x e) = proc env -> + returnA -< Fun (proc v -> eval e -< (x,v):env) +eval (App e1 e2) = proc env -> + (eval e1 -< env) `bind` \ ~(Fun f) -> + (eval e2 -< env) `bind` \ v -> + f -< v + +bind :: Arrow a => a b c -> a (b,c) d -> a b d +e `bind` f = returnA &&& e >>> f + +-- some tests + +i = Lam "x" (Var "x") +k = Lam "x" (Lam "y" (Var "x")) +double = Lam "x" (Add (Var "x") (Var "x")) + +t = n + where Num n = eval (If (Var "b") + (App (App k (App double (Var "x"))) (Var "x")) + (Add (Var "x") (Add (Var "x") (Var "x")))) + [("b", Bl True), ("x", Num 5)] diff --git a/examples/small/Lift.hs b/examples/small/Lift.hs new file mode 100644 --- /dev/null +++ b/examples/small/Lift.hs @@ -0,0 +1,13 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} +module Lift where + +import Control.Arrow + +-- lifting a binary operation to arrows (Hughes's paper, s4.1) + +liftA2' :: Arrow a => (b -> c -> d) -> a e b -> a e c -> a e d +liftA2' op f g = proc x -> do + y <- f -< x + z <- g -< x + returnA -< y `op` z diff --git a/examples/small/ListOps.hs b/examples/small/ListOps.hs new file mode 100644 --- /dev/null +++ b/examples/small/ListOps.hs @@ -0,0 +1,29 @@ +{- LANGUAGE Arrows -} +{-# OPTIONS -F -pgmF arrowp-ext #-} +module ListOps where + +-- generalizing map and filter to arrows + +-- Note that these need ArrowChoice (because they use case) but +-- not ArrowApply (because the arrows used before -< don't involve +-- variables defined inside the arrow abstraction). + +import Control.Arrow + +mapA :: ArrowChoice a => a (b, c) d -> a (b, [c]) [d] +mapA f = proc (env, xs) -> case xs of + [] -> + returnA -< [] + x:xs -> do + y <- f -< (env, x) + ys <- mapA f -< (env, xs) + returnA -< y:ys + +filterA :: ArrowChoice a => a (b, c) Bool -> a (b, [c]) [c] +filterA p = proc (env, xs) -> case xs of + [] -> + returnA -< [] + x:xs -> do + b <- p -< (env, x) + ys <- filterA p -< (env, xs) + returnA -< if b then x:ys else ys diff --git a/src/ArrCode.hs b/src/ArrCode.hs new file mode 100644 --- /dev/null +++ b/src/ArrCode.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +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, app, loop, returnA + ) where +import Data.Default +import Data.Set (Set) +import qualified Data.Set as Set +import Debug.Hoed.Pure +import Language.Haskell.Exts.Syntax hiding (Let, Tuple) +import qualified Language.Haskell.Exts.Syntax as H +import Utils + +data Arrow = Arrow + { context :: Tuple -- named input components used by the arrow + , anonArgs :: Int -- number of unnamed arguments + , code :: Code + } + deriving (Eq, Generic, Show) + +instance Located Arrow where + type LocType Arrow = S + location f (Arrow context anon code)= + Arrow <$> location f context <*> pure anon <*> location f code + +instance Observable Arrow + +data VarDecl a = VarDecl (Name S) a + deriving (Functor, Generic) + +instance (Located a, LocType a ~ S) => Located (VarDecl a) where + type LocType (VarDecl a) = S + location f (VarDecl n a) = VarDecl <$> location f n <*> location f a + +-- required Undecidable instances +deriving instance (Eq a) => Eq (VarDecl a) +deriving instance (Show a) => Show (VarDecl a) + +instance Observable a => Observable (VarDecl a) + +data Code + = ReturnA -- returnA = arr id + | Arr Int (Pat S) [Binding] (Exp S) -- arr (first^n (\p -> ... e)) + | Compose Code [Code] Code -- composition of 2 or more elts + | Op (Exp S) [Code] -- combinator applied to arrows + | InfixOp Code (QOp S) Code + | Let [VarDecl Code] Code + | Ifte (Exp S) Code Code + deriving (Eq, Generic, Show) + +instance Located Code where + type LocType Code = S + location _ ReturnA = pure ReturnA + location f (Arr i pat bb e) = + Arr i <$> location f pat <*> location f bb <*> location f e + location f (Compose c1 cc c2) = + Compose <$> location f c1 <*> location f cc <*> location f c2 + location f (Op e cc) = Op <$> location f e <*> location f cc + location f (InfixOp c qop c') = InfixOp <$> location f c <*> location f qop <*> location f c' + location f (Let vv c) = Let <$> location f vv <*> location f c + location f (Ifte e c1 c2) = Ifte <$> location f e <*> location f c1 <*> location f c2 + +instance Observable Code + +data Binding = BindLet (Binds S) | BindCase (Pat S) (Exp S) + deriving (Eq,Generic, Show) +instance Observable Binding + +instance Located Binding where + type LocType Binding = S + location f (BindLet b) = BindLet <$> location f b + location f (BindCase p e) = BindCase <$> location f p <*> location f e + +loop :: Arrow -> Arrow +loop f = applyOp loop_exp [f] + +app, returnA :: Arrow +app = arrowExp app_exp +returnA = arrowExp returnA_exp + +bind :: Set (Name S) -> Arrow -> Arrow +bind = observe "bind" $ \vars a -> a {context = context a `minusTuple` vars} +anon :: Int -> Arrow -> Arrow +anon anonCount a = a {anonArgs = anonArgs a + anonCount} +arr + :: Int -> Tuple -> Pat S -> Exp S -> Arrow +arr = observe "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 + } +arrLet :: Int -> Tuple -> Pat S -> Binds S -> Exp S -> 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` freeVarss ds) `Set.difference` definedVars ds +ifte :: Exp S -> 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 :: Exp S -> Arrow +arrowExp e = + Arrow + { code = + if e == returnA_exp + then ReturnA + else Op e [] + , context = emptyTuple + , anonArgs = 0 + } +applyOp :: Exp S -> [Arrow] -> Arrow +applyOp e as = + Arrow + { code = Op e (map code as) + , context = foldr (unionTuple . context) emptyTuple as + , anonArgs = 0 -- BUG: see below + } + +infixOp :: Arrow -> QOp S -> 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 + } + +compose :: Code -> Code -> Code +compose = observe "compose" compose' + +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 +compose' (Compose f1 as1 g1) (Compose f2 as2 g2) = + Compose f1 (as1 ++ (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 + +toHaskell :: Arrow -> Exp S +toHaskell = rebracket1 . toHaskellCode . code + where + toHaskellCode :: Code -> Exp S + toHaskellCode ReturnA = returnA_exp + toHaskellCode (Arr n p bs e) = + App def arr_exp (times n (Paren def . App def first_exp) body) + where + body = Lambda def [p] (foldr addBinding e bs) + addBinding (BindLet ds) e = H.Let def ds e + addBinding (BindCase p e) e' = + Case def e [Alt def p (UnGuardedRhs def e') Nothing] + toHaskellCode (Compose f as g) = + foldr (comp . toHaskellArg) (toHaskellArg g) (f : as) + where + comp f = InfixApp def f compose_op + toHaskellCode (Op op as) = foldl (App def) op (map (Paren def . toHaskellCode) as) + toHaskellCode (InfixOp a1 op a2) = + InfixApp def (toHaskellArg a1) op (toHaskellArg a2) + toHaskellCode (Let nas a) = + H.Let def (BDecls def $ map toHaskellDecl nas) (toHaskellCode a) + where + toHaskellDecl (VarDecl n a) = + PatBind def (PVar def n) (UnGuardedRhs def (toHaskellCode a)) Nothing + toHaskellCode (Ifte cond th el) = If def cond (toHaskellCode th) (toHaskellCode el) + + toHaskellArg = Paren def . toHaskellCode + +newtype Tuple = Tuple (Set (Name S)) + deriving (Eq,Generic,Show) +instance Observable Tuple + +instance Located Tuple where + type LocType Tuple = S + location f (Tuple names) = Tuple <$> location f names + +isEmptyTuple :: Tuple -> Bool +isEmptyTuple (Tuple t) = Set.null t + +patternTuple :: Tuple -> Pat S +patternTuple (Tuple []) = PApp def (unit_con_name def) [] +patternTuple (Tuple [x]) = PVar def x +patternTuple (Tuple t) = PTuple def Boxed (map (PVar def) (Set.toList t)) + +expTuple :: Tuple -> Exp S +expTuple (Tuple []) = unit_con def +expTuple (Tuple [t]) = Var def $ UnQual def t +expTuple (Tuple t) = H.Tuple def Boxed (map (Var def . UnQual def) (Set.toList t)) + +emptyTuple :: Tuple +emptyTuple = Tuple Set.empty +unionTuple :: Tuple -> Tuple -> Tuple +unionTuple (Tuple a) (Tuple b) = Tuple (a `Set.union` b) + +minusTuple :: Tuple -> Set (Name S) -> Tuple +Tuple t `minusTuple` vs = Tuple (t `Set.difference` vs) +intersectTuple :: Tuple -> Set (Name S) -> Tuple +intersectTuple = observe "intersectTuple" intersectTuple' +intersectTuple' :: Tuple -> Set (Name S) -> Tuple +Tuple t `intersectTuple'` vs = Tuple (t `Set.intersection` vs) diff --git a/src/ArrCode.lhs b/src/ArrCode.lhs deleted file mode 100644 --- a/src/ArrCode.lhs +++ /dev/null @@ -1,245 +0,0 @@ -> 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.hs b/src/ArrSyn.hs new file mode 100644 --- /dev/null +++ b/src/ArrSyn.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module ArrSyn + ( translate + ) where + +import ArrCode +import Utils + +import Control.Monad.Trans.State +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 Debug.Hoed.Pure +import Language.Haskell.Exts (Alt (..), Binds (..), Decl (..), + Exp (), GuardedRhs (..), + Match (..), Name, Pat (..), + Rhs (..), Stmt (..), ann) + +import qualified Language.Haskell.Exts as H + +-- ----------------------------------------------------------------------------- +-- 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 :: Pat S -> Exp S -> Exp S +translate p c = H.Paren (ann c) $ toHaskell (transCmd s p' c) + where (s, p') = startPattern p + +startPattern :: Pat S -> (TransState, Pat S) +startPattern = observe "startPattern" startPattern' + +startPattern' :: Pat S -> (TransState, Pat S) +startPattern' p = + (TransState { + locals = definedVars p, + cmdVars = Map.empty + }, 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 -> Pat S -> Exp S -> Arrow +transCmd = observe "transCmd" transCmd' + +transCmd' :: TransState -> Pat S -> Exp S -> Arrow +transCmd' s p (H.LeftArrApp l 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 (H.LeftArrHighApp l f e) = transCmd s p (H.LeftArrApp l f e) +transCmd' s p (H.RightArrApp l f e) = transCmd s p (H.LeftArrApp l e f) +transCmd' s p (H.RightArrHighApp l f e) = transCmd s p (H.LeftArrHighApp l e f) +transCmd' s p (H.InfixApp l c1 op c2) = + infixOp (transCmd s p c1) op (transCmd s p c2) +transCmd' s p (H.Let l 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 (H.If l 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 (H.If l e (left e1) (right e2)) >>> (a1 ||| a2) + where (e1, a1) = transTrimCmd s c1 + (e2, a2) = transTrimCmd s c2 +transCmd' s p (H.Case l e as) = + arr 0 (input s) p (H.Case l e as') >>> foldr1 (|||) (reverse cases) + where + (as', (ncases, cases)) = runState (mapM (transAlt s) as) (0, []) + transAlt = observeSt "transAlt" transAlt' + transAlt' s (Alt loc p gas decls) = do + let (s', p') = addVars' s p + (s'', decls') = addVars' s' decls + gas' <- transGuardedRhss s'' gas + return (H.Alt loc p' gas' decls') + transGuardedRhss = observeSt "transGuardedRhss" transGuardedRhss' + transGuardedRhss' s (UnGuardedRhs l c) = do + body <- newAlt s c + return (H.UnGuardedRhs l body) + transGuardedRhss' s (GuardedRhss l gas) = do + gas' <- mapM (transGuardedRhs s) gas + return (H.GuardedRhss l gas') + transGuardedRhs = observeSt "transGuardedRhs" transGuardedRhs' + transGuardedRhs' s (GuardedRhs loc e c) = do + body <- newAlt s c + return (H.GuardedRhs loc e body) + newAlt = observeSt "newAlt" newAlt' + newAlt' s c = do + let (e, a) = + transTrimCmd s c + (n, as) <- get + put (n + 1, a : as) + return (label n e) + label = observe "label" label' + label' n e = + times + n + right + (if n < ncases - 1 + then left e + else e) +transCmd' s p (H.Paren _ c) = + transCmd s p c +transCmd' s p (H.Do l ss) = + transDo s p (init ss) (let Qualifier _ e = last ss in e) +transCmd' s p (H.App l c arg) = + anon (-1) $ + arr (anonArgs a) (input s) p (pair e arg) >>> a + where (e, a) = transTrimCmd s c +transCmd' s p (H.Lambda l ps c) = + anon (length ps) $ bind (definedVars ps) $ transCmd s' (foldl pairP p ps') c + where + (s', ps') = addVars' s ps +transCmd' _ _ x = error $ "transCmd: " ++ show x + +-- transCmd' s p (CmdVar n) = +-- arr (anonArgs a) (input s) p e >>> arrowExp (H.Var () (H.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 -> Exp S -> (Exp S, Arrow) +transTrimCmd = observe "transTrimCmd" transTrimCmd' +transTrimCmd' :: TransState -> Exp S -> (Exp S, Arrow) +transTrimCmd' s c = (expTuple (context a), a) + where a = transCmd s (patternTuple (context a)) c + +transDo :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow +transDo = observe "transDo" transDo' + +transDo' :: TransState -> Pat S -> [Stmt S] -> Exp S -> Arrow +transDo' s p [] c = + transCmd s p c +transDo' s p (Qualifier l exp : ss) c = + transDo' s p (Generator l (PWildCard l) exp : ss) c +transDo' s p (Generator l 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 = observe "a" $ bind (definedVars pg) + (transDo s' (pairP pg' (patternTuple u)) ss c) + u = observe "u" $ context a + (eg, ag) = transTrimCmd s cg +transDo' s p (LetStmt l decls : ss) c = + transCmd s p (H.Let l decls (H.Do l (ss ++ [Qualifier l c]))) +transDo' s p (RecStmt l rss:ss) c = + bind + defined + (loop + (transDo + s' + (pairP p (irrPat (patternTuple feedback))) + rss' + (returnCmd (pair output (expTuple feedback)))) >>> + a) + where + defined = foldMap definedVars rss + (s', rss') = addVars' s rss + (output, a) = transTrimCmd s' (H.Do l (ss ++ [Qualifier l c])) + feedback = + context + (transDo + s' + p + rss' + (returnCmd + (foldr (pair . H.Var l . H.UnQual l) output (Set.toList defined)))) `intersectTuple` + defined + +data TransState = TransState { + locals :: Set (Name S), -- vars in scope defined in this proc + cmdVars :: Map (Name S) Arrow + } deriving (Eq, Generic, Show) + +instance Observable TransState + +input :: TransState -> Tuple +input s = Tuple (locals s) + +addVars' + :: (Observable a, AddVars a, Eq l, Show l, l ~ LocType a) + => TransState -> a -> (TransState, a) +addVars' = observe "addVars" addVars + +class AddVars a where + addVars :: TransState -> a -> (TransState, a) + +instance AddVars a => AddVars [a] where + addVars = mapAccumL addVars + +instance AddVars a => AddVars (Maybe a) where + addVars = mapAccumL addVars + +instance AddVars (Pat S) where + addVars s p = + (s {locals = locals s `Set.union` definedVars p}, p) + +instance AddVars (Decl S) where + addVars s d@(FunBind l (Match _ n _ _ _:_)) = + (s', d) + where (s', _) = addVars s (PVar l n) + addVars s (PatBind loc p rhs decls) = + (s', PatBind loc p' rhs decls) + where (s', p') = addVars s p + addVars s d = (s, d) + +instance AddVars (Stmt S) where + addVars s it@Qualifier{} = (s, it) + addVars s (Generator loc p c) = + (s', Generator loc p' c) + where (s', p') = addVars s p + addVars s (LetStmt l decls) = + (s', LetStmt l decls') + where (s', decls') = addVars s decls + addVars s (RecStmt l stmts) = + (s', RecStmt l stmts') + where (s', stmts') = addVars s stmts + +instance AddVars (Binds S) where + addVars s (BDecls l decls) = BDecls l <$> addVars s decls + addVars s it@IPBinds{} = (s, it) diff --git a/src/ArrSyn.lhs b/src/ArrSyn.lhs deleted file mode 100644 --- a/src/ArrSyn.lhs +++ /dev/null @@ -1,304 +0,0 @@ -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/Notation.hs b/src/Control/Arrow/Notation.hs new file mode 100644 --- /dev/null +++ b/src/Control/Arrow/Notation.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Control.Arrow.Notation + ( translateModule + , translateExp + ) where + +import Data.Generics.Uniplate.Data +import Language.Haskell.Exts as H hiding (Tuple) + +import ArrSyn +import Utils + +translateModule :: Module SrcSpanInfo -> Module SrcSpanInfo +translateModule = transformBi translateExp + +translateExp :: Exp SrcSpanInfo -> Exp SrcSpanInfo +translateExp (Proc _ pat exp) = + getSrcSpanInfo <$> ArrSyn.translate (fmap S pat) (fmap S exp) +translateExp other = other diff --git a/src/Control/Arrow/QuasiQuoter.hs b/src/Control/Arrow/QuasiQuoter.hs --- a/src/Control/Arrow/QuasiQuoter.hs +++ b/src/Control/Arrow/QuasiQuoter.hs @@ -1,24 +1,17 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} module Control.Arrow.QuasiQuoter ( proc - , parseModuleWithMode ) where -import Data.Maybe +import Control.Arrow.Notation +import Data.List -import Language.Haskell.TH +import Language.Haskell.Exts as Exts hiding (Exp, Loc) +import Language.Haskell.Meta +import Language.Haskell.TH (Exp, Q, Loc(..), location ) 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. @@ -38,136 +31,27 @@ } quote :: String -> Q Exp -quote inp = - case parseProc ("proc " ++ inp) of - ParseOk proc -> tr proc +quote = quoteEx defaultParseMode { extensions = defaultExtensions } + +quoteEx :: ParseMode -> String -> Q Exp +quoteEx mode inp = + case parseExpWithMode mode ("proc " ++ inp) of + ParseOk proc -> return $ toExp $ translateExp 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" - +defaultExtensions :: [Extension] +defaultExtensions = [e | e@EnableExtension{} <- knownExtensions] \\ map EnableExtension badExtensions -instance Translate HsName [Char] where - tr (HsSymbol s) = return s - tr (HsIdent n) = return n +badExtensions :: [KnownExtension] +badExtensions = + [TransformListComp -- steals the group keyword + ,XmlSyntax, RegularPatterns -- steals a-b + ,UnboxedTuples -- breaks (#) lens operator + ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + ,DoRec, RecursiveDo -- breaks rec + ,TypeApplications -- HSE fails on @ patterns + ] diff --git a/src/Lexer.hs b/src/Lexer.hs deleted file mode 100644 --- a/src/Lexer.hs +++ /dev/null @@ -1,564 +0,0 @@ --- #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 deleted file mode 100644 --- a/src/Parser.ly +++ /dev/null @@ -1,997 +0,0 @@ -> { -> ----------------------------------------------------------------------------- -> -- | -> -- 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 deleted file mode 100644 --- a/src/State.hs +++ /dev/null @@ -1,6 +0,0 @@ --- 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.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing -Wno-orphans #-} +module Utils + ( module Utils + , HSE.Located(..) + , HSE.rebracket1 + )where + +import Control.Monad +import Control.Monad.Trans.State +import Data.Data +import Data.Default +import Data.Functor.Identity +import Data.Generics.Uniplate.Data +import Data.List +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Set as Set +import Debug.Hoed.Pure hiding (Module) +import Language.Haskell.Exts +import qualified Language.Haskell.Exts.Util as HSE +#ifdef DEBUG +import Language.Haskell.Exts.Observe () +#endif + +-- | The type of src code locations used by arrowp-qq +newtype S = S {getSrcSpanInfo :: SrcSpanInfo} + deriving (Data, Typeable) +instance Eq S where _ == _ = True +instance Ord S where compare _ _ = EQ +instance Show S where show _ = "" + +instance Default S where + def = S noSrcSpan + +instance Observable S where + observer = observeOpaque "" + constrain = constrainBase + +freeVars + :: (Observable a, HSE.FreeVars a, S ~ HSE.LocType a) + => a -> Set (Name S) +freeVars = observe "freeVars" HSE.freeVars + +freeVarss + :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a) + => a -> Set (Name S) +freeVarss = observe "freeVarss" (HSE.free . HSE.allVars) + +definedVars + :: (Observable a, HSE.AllVars a, S ~ HSE.LocType a) + => a -> Set (Name S) +definedVars = observe "definedVars" (HSE.bound . HSE.allVars) + +-- | Are a tuple pattern and an expression tuple equal ? +same :: Pat S -> Exp S -> Bool +same = observe "same" same' + +same' :: Pat S -> Exp S -> Bool +same' (PApp _ n1 []) (Con _ n2) = n1 == n2 +same' (PVar l n1) (Var _ n2) = UnQual l n1 == n2 +same' (PTuple _ Boxed []) y = same (PApp (ann y) (unit_con_name (ann y)) []) y +same' (PTuple _ Boxed [pv]) y = same pv y +same' y (Tuple _ Boxed []) = same y (unit_con(ann y)) +same' y (Tuple _ Boxed [pv]) = same y pv +same' (PTuple _ boxed ps) (Tuple _ boxed' es) = + length ps == length es && boxed == boxed' && and (zipWith same ps es) +same' (PAsPat _ n _) (Var _ (UnQual _ n')) = n == n' +same' (PAsPat _ _ p) e = same p e +same' (PParen _ p) e = same p e +same' p (Paren _ e) = same p e +same' _ _ = False + +times :: Int -> (a -> a) -> a -> a +times n f x = iterate f x !! n + +-- | Hide variables from a pattern +hidePat :: Set (Name S) -> Pat S -> Pat S +hidePat vs = transform (go vs) where + go vs p@(PVar l n) + | n `Set.member` vs = PWildCard l + | otherwise = p + go vs (PAsPat _ n p) + | n `Set.member` vs = go vs p + go _ x = x + +pair :: Exp S -> Exp S -> Exp S +pair e1 e2 = Tuple (ann e1) Boxed [e1, e2] + +pairP :: Pat S -> Pat S -> Pat S +pairP p1 p2 = PTuple (ann p1) Boxed [hidePat (definedVars p2) p1, p2] + +left, right :: Exp S -> Exp S +left x = App (ann x) left_exp (Paren def x) +right x = App (ann x) right_exp (Paren def x) + +returnCmd :: Exp S -> Exp S +returnCmd x = LeftArrApp (ann x) returnA_exp x + +compose_op, choice_op :: QOp S +returnA_exp, arr_exp, first_exp :: Exp S +left_exp, right_exp, app_exp, loop_exp :: Exp S +unqualId :: String -> Exp S +unqualId id = Var def $ UnQual def (Ident def id) +unqualOp :: String -> QOp S +unqualOp id = QVarOp def $ UnQual def (Symbol def id) +unqualCon :: String -> Exp S +unqualCon id = Con def $ UnQual def (Symbol def id) +arr_exp = unqualId "arr" +compose_op = unqualOp ">>>" +first_exp = unqualId "first" +returnA_exp = unqualId "returnA" +choice_op = unqualOp "|||" +left_exp = unqualCon "Left" +right_exp = unqualCon "Right" +app_exp = unqualId "app" +loop_exp = unqualId "loop" + + +-- | Irrefutable version of a pattern + +irrPat :: Pat S -> Pat S +irrPat p@PVar{} = p +irrPat (PParen l p) = PParen l (irrPat p) +irrPat (PAsPat l n p) = PAsPat l n (irrPat p) +irrPat p@PWildCard{} = p +irrPat p@PIrrPat{} = p +irrPat p = PIrrPat (ann p) p + +-- | Observing functions for algorithmic debugging + +observeSt + :: (Observable a, Observable b, Observable c, Observable s) + => String -> (a -> b -> State s c) -> a -> b -> State s c +observeSt name f a b = StateT $ \s -> Identity $ observe name f' a b s + where + f' a b = runState (f a b) + +instance (Eq a, Show a) => Observable (Set a) where + constrain = constrainBase + observer = observeBase + +instance (Eq a, Eq k, Show a, Show k) => Observable (Map k a) where + constrain = constrainBase + observer = observeBase + +-- Override some AST instances for comprehension +instance {-# OVERLAPS #-} Observable (Exp S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (Name S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (QName S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable [Stmt S] where + observer lit cxt = + seq lit $ send (bracket $ intercalate ";" $ fmap prettyPrint lit) (return lit) cxt +instance {-# OVERLAPS #-} Observable (Stmt S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (Pat S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (QOp S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (Op S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (Rhs S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (Alt S) where + observer = observePretty +instance {-# OVERLAPS #-} Observable (Set (Name S)) where + constrain = constrainBase + observer x cxt = + seq x $ send (between "[" "]"$ intercalate "," $ prettyPrint <$> map void (Set.toList x)) (return x) cxt + +observePretty lit cxt = + seq lit $ send (between "<" ">" $ prettyPrint lit) (return lit) cxt + +bracket :: [Char] -> [Char] +between open close s = open ++ s ++ close +bracket = between "[" "]" diff --git a/src/Utils.lhs b/src/Utils.lhs deleted file mode 100644 --- a/src/Utils.lhs +++ /dev/null @@ -1,204 +0,0 @@ -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)