freesect 0.7 → 0.8
raw patch · 32 files changed
+1232/−615 lines, 32 filessetup-changed
Files
- 000-readme +13/−6
- Doc/index.html +50/−33
- Doc/irc.html +3/−0
- Doc/primitives.html +46/−0
- FilesAndParsing.hs +6/−7
- FreeSect.hs +370/−0
- FreeSectAnnotated.hs +409/−0
- HSE/Annotated/Build.hs +6/−6
- HSE/Annotated/ExactPrint.hs +4/−4
- HSE/Annotated/Simplify.hs +1/−1
- HSE/Annotated/Syntax.hs +2/−2
- HSE/Build.hs +6/−6
- HSE/InternalParser.hs +1/−1
- HSE/InternalParser.ly +4/−4
- HSE/Lexer.hs +1/−1
- HSE/ParseSyntax.hs +4/−4
- HSE/ParseUtils.hs +1/−1
- HSE/Pretty.hs +8/−8
- HSE/Syntax.hs +1/−1
- Main.hs +46/−485
- Makefile +7/−1
- S24.hs +7/−4
- S25.hs +13/−8
- S27.hs +36/−2
- Setup.hs +1/−1
- Util.hs +129/−0
- cln +4/−1
- freesect.cabal +18/−14
- freesect.sh +1/−0
- ile +8/−2
- z +17/−11
- zpack +9/−1
000-readme view
@@ -1,28 +1,34 @@ -Wed Feb 29 20:03:57 EST 2012+Wed Mar 21 07:47:54 EDT 2012 +[ freesect-0.8 readme file ]+ There is a snapshot of documentation in Doc, but please visit the homepage for up-to-date versions: http://www.fremissant.net/freesect Tested with Haskell Platforms 6.12.3 and 7.0.4. Testing has not been very extensive yet.-Will try to get a quickcheck harness into freesect-0.0.8.+Will try to get a quickcheck harness by freesect-1.0. A patched version of haskell-src-exts is used. These patched modules are provisionally renamed HSE to avoid confusion. I think it is HSE which makes the executable so big? +cabal-install should work, but in case not, you can build it manually. To compile, you need syb installed, as well as some dependencies of the HSE code (the freesect.cabal file details dependencies). -cabal-install should work, but in case not, you can build it manually.+Running with PARALLEL set (see ./z for all available options) will not+work with 6.12.3 unless the parallel package is upgraded. If you use+cabal-install to install freesect, the upgrade should be automatic.+ To build and run, please have csh (or tcsh), and run the ./z script: ./z -The script is hardcoded to use the S25.hs test file, but-you can easily adjust that.+The script uses the S25.hs test file by default, but you can+supply the pathname of any module(s) on the command line. Preprocessed outputs can be examined in ./ghc* directories, unless you've unset the GHC_F option, in which case the outputs will be@@ -30,5 +36,6 @@ For more information, visit http://www.fremissant.net/freesect -Andrew Seniuk (rasfar@gmail.com)+Andrew Seniuk <rasfar@gmail.com>+Feb 29, 2012
Doc/index.html view
@@ -71,7 +71,7 @@ <h3 style="margin-top: 10px; margin-bottom: 0;">Haskell Syntax Extension</h3> <h5 style="margin-top: 10px; margin-bottom: 28px;">by Andrew Seniuk</h5> -<div style="color: #B52; font-size: 9pt; font-weight: bold; margin-left: 20px; margin-right: 20%; margin-bottom: 15px; margin-top: 10px;">The reader is strongly encouraged to navigate to <a href="http://www.fremissant.net/freesect">fremissant.net/freesect</a> as these documents are currently experiencing rapid growth and refinement. The local files represent the best documentation available at packaging of this v0.7 source distribution (March 15, 2012).</div>+<div style="color: #B52; font-size: 9pt; font-weight: bold; margin-left: 20px; margin-right: 20%; margin-bottom: 15px; margin-top: 10px;">The reader is strongly encouraged to navigate to <a href="http://www.fremissant.net/freesect">fremissant.net/freesect</a> as these documents are currently experiencing rapid growth and refinement. The local files represent the best documentation available at packaging of this v0.8 source distribution (March 18, 2012).</div> <i>Free sections</i> are syntactic sugar to extend the usual notion of "section" in functional programming.@@ -85,14 +85,14 @@ f 4 True -- Char -> Float -> String </pre> -By using wildcard symbols (<pre2>__</pre2>, a double-underscore), any subset of values occurring in a RHS context can be deferred, in the same spirit as partial function application.+With free sections, by using wildcard symbols (<pre2>__</pre2>, a double-underscore), any subset of values occurring in a RHS context can be deferred, in the same spirit as partial function application. When necessary, special brackets (<pre2>_[</pre2><pre3>…</pre3><pre2>]_</pre2>) are used to delimit the lexical extent (or context) of the section, although these can usually be omitted (details below). The free section is then a function with arity at least equal to the number of wildcards, and behaves as if a helper function had been defined which shuffled the argument order of the functional expression, turning it into a normal section. <p> Philosophically, use of this sort of syntax promotes "higher-order programming", since any expression can so easily be made into a function, in numerous ways, simply by replacing parts of it with freesect wildcards. That this is worthwhile is demonstrated by the frequent usefulness of sections. <p>-The <a href="http://www.fremissant.net/freesect/primitives.html">complete table</a> of Haskell expression translations probably forms the best set of examples I have to offer.+The <a href="./primitives.html">complete table</a> of Haskell expression translations probably forms the best set of examples I have to offer. Some other examples, including illustrations of context inferencing: <pre> map <pre3>_</pre3>[ (+) <pre3><pre3>__</pre3></pre3> 2 ]<pre3>_</pre3> [1,2,3] = [3,4,5]@@ -103,30 +103,31 @@ For a more complex example, consider a situation where some API provides you with the dreaded <pre2>dreadme</pre2> function, which you have need of using. The example is designed to show that you can really put the <pre2>__</pre2>'s anywhere on a RHS that an expression can go. -<pre> {-# LANGUAGE FreeSections #-} -- use "{- #" if compiling with ghc -F-- tableA = [ [1,2,3], [4,5], [6,7,8,9] ]- tableB = [ [9,8,7], [6,5], [4,3,2,1] ]-- data D a = D Int [a]-- v = map3 ( dreadme tableA <pre3>__</pre3> (repeat True,<pre3>__</pre3>) (D <pre3>__</pre3> [(+),(*)]) )- [tableA,tableB]- [0..]- [-1,1]+<pre> map3 ( dreadme tableA <pre3>__</pre3> (repeat True,<pre3>__</pre3>) (D <pre3>__</pre3> [(+),(*)]) )+ [tableA,tableB]+ [0..]+ [-1,1] </pre> FreeSect rewrites the RHS of <pre2>v</pre2> (where <pre2>fs0</pre2><pre3>…</pre3><pre2>fs2</pre2> must be fresh identifiers) to: -<pre> v = map3 (\ fs0 fs1 fs2 -> dreadme tableA fs0 (repeat True,fs1) (D fs2 [(+),(*)]) )- [tableA,tableB]- [0..]- [-1,1]+<pre>+ map3 (\ fs0 fs1 fs2 -> dreadme tableA fs0 (repeat True,fs1) (D fs2 [(+),(*)]) )+ [tableA,tableB]+ [0..]+ [-1,1] </pre> (Here is <a id="collapsed1" href="#collapsed1" onclick="collapse(this,'.showhide1');">the rest</a> of the code to make a closed module.) <pre class="showhide1" style="display: none;"> dreadme :: [[Int]] -> [[Int]] -> ([Bool],Int) -> D (Int->Int->Int) -> String+ {-# LANGUAGE FreeSections #-} -- use "{- #" if compiling with ghc -F++ tableA = [ [1,2,3], [4,5], [6,7,8,9] ]+ tableB = [ [9,8,7], [6,5], [4,3,2,1] ]++ data D a = D Int [a]+ dreadme tabA tabB (ps,q) (D wt flst) = show $ map (!!q) $ map2 f tabA tabB where f rowA rowB = map2 (<) (repeat rowA)@@ -180,32 +181,47 @@ <h2>Implementation</h2> -The <a href="http://www.fremissant.net/freesect/freesect-0.7.tar.gz">implementation</a> seems to be working.-The <pre2>freesect</pre2> package can also be installed from <a href="http://hackage.haskell.org/package/freesect">Hackage</a>, for instance using <pre2>cabal-install</pre2>.+The <a href="./freesect-0.8.tar.gz">implementation</a> seems to be working.+The <pre3>freesect</pre3> package can also be installed from <a href="http://hackage.haskell.org/package/freesect">Hackage</a>, for instance using <pre3>cabal-install</pre3>. I offer fair warning that I'm <i>not</i> a good Haskell coder, but this does demonstrate how a person of modest abilities can use <a href="http://hackage.haskell.org/package/syb">SYB</a> with <a href="http://hackage.haskell.org/package/haskell-src-exts">HSE</a> to create a robust Haskell syntax extension. <h2>Default context inferencing</h2> -<b>Note</b>: The following policy is flawed as pointed out by <pre3><ski></pre3> on <pre3>#haskell</pre3>, since+<div style="margin-left: 20px; margin-right: 50px; font-size: 11pt; font-weight: bold; color: #453;">+<b>Note</b>: The following policy is flawed, as pointed out by <pre3><ski></pre3> on <pre3>#haskell</pre3>, since <br />-<pre style="font-size: 12pt; font-weight: normal;">- <ski> this clearly means that `(f __) a' (meaning `(\x -> f x) a') is- different from `f __ a' (meaning `\x -> f x a')+<pre style="font-size: 10pt; font-weight: normal; color: #000;">+ <ski> this clearly means that `(f __) a' (meaning `(\x <span style="font-family: monospace;">-></span> f x) a') is+ different from `f __ a' (meaning `\x <span style="font-family: monospace;">-></span> f x a') </pre>-+If we could prove that these two interpretations cannot both be given consistent types in the same context, things wouldn't be so bad, but unfortunately taking <pre3>f=(-)</pre3> is enough to see there is no hope for that, as+<br />+<pre style="font-size: 10pt; font-weight: normal; color: #000;">+ (\x <span style="font-family: monospace;">-></span> (-) x) 3 2<span style="font-family: monospace;"> => </span>(-) 3 2<span style="font-family: monospace;"> => </span>-1+ (\x <span style="font-family: monospace;">-></span> (-) x 3) 2<span style="font-family: monospace;"> => </span>(-) 2 3<span style="font-family: monospace;"> => </span> 1+</pre>+Rum luck!+As <pre3><ski></pre3> kindly observed, people don't often write (f x) y because application already associates left, but still, the policy is flawed because the Haskell semantics are not respected 100%.+There may be other lurking problems which testing will eventually expose…+<p>+To deal with this, since v0.8 the preprocessor issues a warning (and possible remedy) when freesect wildcards occur within redundantly-parenthesised applications.+</div>+<p> A default context is automatically applied when the <pre2>_[</pre2><pre3>…</pre3><pre2>]_</pre2> grouping syntax is omitted. Defining this default can be tricky, and a bit arbitrary, so for robust code it's best to use explicit bracketing.-As of v0.6, when the <pre2>_[</pre2><pre3>…</pre3><pre2>]_</pre2> are omitted, the defaulting rules are as follows:-The semilattice join of all unbacketed wildcards in a RHS are given context of the innermost enclosing parentheses or infix <pre2>$</pre2> operation.-If no such parentheses or infix <pre2>$</pre2> are present, the whole RHS becomes the default context.+Since v0.6, when the <pre2>_[</pre2><pre3>…</pre3><pre2>]_</pre2> are omitted, the defaulting rules are as follows:+The set of all unbracketed wildcards in a RHS are given context of their collective innermost enclosing parentheses, infix <pre2>$</pre2> operator, or list brackets (whichever is tightest).+In v0.8, list brackets were also added to this set of delimiters.+If none of these delimiters is present, the whole RHS becomes the default context. Some of the examples demonstrate these rules.+<p> One hopes that the default will result in a type error, should the inferred context differ from the intended. I haven't thought of any situation where more than one bracketing of freesect wildcards yield typeable expressions, but neither have I ruled it out.-A context inference policy based on typeability tests among various possible scopes would also be possible, although probably ill-advised.+A context inference policy based on typeability tests among the candidate scopes would also be possible, although probably ill-advised. <h2>Background</h2> -There was <a href="http://www.fremissant.net/freesect/irc.html">discussion</a>+There was <a href="./irc.html">discussion</a> about this on the <pre4>#haskell</pre4> IRC channel. Strangely, <pre4><eyebloom></pre4> suggested the same thing an hour after I had started making inquiries about how to go about writing an extension -- and this is the one I had in mind. It's an extraordinary coincidence, as I first sketched the idea in 2003, and had never seen it mentioned <i>per se</i>, beyond discussions of point-free and the like.@@ -237,7 +253,8 @@ <pre> map (\a->foo (g a) x) (\b->h b) </pre>-This interpretation cannot by typed, since the second argument of <pre2>map</pre2> must be have kind <pre2>*</pre2>, while <pre2>\b->h b</pre2> has kind <pre2>*->*</pre2>.+This interpretation cannot by typed, since the second argument of <pre2>map</pre2> must be have kind <pre2>*</pre2>, while <pre2>\b<span style="font-family: monospace;">-></span>h b</pre2> has kind <pre2>*<span style="font-family: monospace;">-></span>*</pre2>.+<!-- XXX Is this even a correct use of "kind"?... --> <h2>Other details</h2> @@ -248,8 +265,8 @@ There is no danger of exporting these names inadvertently, as they never have top-level scope. Imported names which are in scope but never used will not incur conflicts. <p>-A few things don't work quite right yet, such as list comprehensions.-Work continues...+A few things don't work quite right yet, such as wildcards in list comprehension guards.+Work continues… <h2>How to run it</h2>
Doc/irc.html view
@@ -3,6 +3,7 @@ <title>FreeSect - #haskell discussion (Feb. 22, 2012)</title> <meta http-equiv="Expires" content="Sat, 1 Jan 2000 08:00:00 GMT" /> </head>+<br /> Feb. 22, 2012 -- some omissions and contractions of the literal logs.<br /><br /> <table> <tr valign="top"><td>00:30:40</td><td><eyebloom></td><td>Instead of f x y z you could write f _ _ z</td></tr>@@ -95,4 +96,6 @@ <tr valign="top"><td>00:50:37</td><td><nand`></td><td>but then you run into situations such as nesting those</td></tr> <tr valign="top"><td>00:52:49</td><td><nand`></td><td>(\a -> f _ 42 _ a) could be assumed equivalent to (\a b c -> f b 42 c a)</td></tr> </table>+<br />+<br /> </html>
+ Doc/primitives.html view
@@ -0,0 +1,46 @@+<html>+<title>FreeSect - Translation Table (all Haskell expressions)</title>+<meta http-equiv="Expires" content="Sat, 1 Jan 2000 08:00:00 GMT" />+<style type="text/css">/*<![CDATA[*/+td { font-family: "Courier New"; font-size: 14; font-weight: bold; }+/*]]>*/+</style>+<body>+<br />+This table illustrates how free sections interact with all the different Haskell98 Exp primitives.+These translations are actual output of the FreeSect preprocessor (≥v0.6), not hypothetical rewrites.+They correspond to test file S25.hs in the distro.+Note they all use default contexts;+the explicitly bracketed versions are in S24.hs.+Of course complex (even nested) free sections can be built up from these primitives.+<p>+<table style="margin-left: 20px;">+<tr valign="top"><td align="right">__ + 2</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> _0 + 2</td></tr>+<tr valign="top"><td align="right">f __</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> f _0</td></tr>+<tr valign="top"><td align="right">__ x</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> _0 x</td></tr>+<tr valign="top"><td align="right">-__</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> -_0</td></tr>+<tr valign="top"><td align="right">\ x <span style="font-family: monospace;">-></span> __ x</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> \ x <span style="font-family: monospace;">-></span> _0 x</td></tr>+<tr valign="top"><td align="right">let x = 2 in __ x</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> let x = 2 in _0 x</td></tr>+<tr valign="top"><td align="right">if __ then __ else __</td><td> = </td><td>\ _0 _1 _2 <span style="font-family: monospace;">-></span> if _0 then _1 else _2</td></tr>+<tr valign="top"><td align="right">case __ of _ <span style="font-family: monospace;">-></span> 2</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> case _0 of _ <span style="font-family: monospace;">-></span> 2</td></tr>+<tr valign="top"><td align="right">(__, 2, __, 4, 5, __, 7)</td><td> = </td><td>\ _0 _1 _2 <span style="font-family: monospace;">-></span> (_0, 2, _1, 4, 5, _2, 7)</td></tr>+<tr valign="top"><td align="right">[__, 2, __, 4, 5, __, 7]</td><td> = </td><td>\ _0 _1 _2 <span style="font-family: monospace;">-></span> [_0, 2, _1, 4, 5, _2, 7]</td></tr>+<tr valign="top"><td align="right">a _[ __ c __ ]_ e</td><td> = </td><td>a (\ _0 _1 <span style="font-family: monospace;">-></span> _0 c _1) e</td></tr>+<tr valign="top"><td align="right">(__)</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> _0</td></tr>+<tr valign="top"><td align="right">(__ b __)</td><td> = </td><td>\ _0 _1 <span style="font-family: monospace;">-></span> _0 b _1</td></tr>+<tr valign="top"><td align="right">(__ +)</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> (_0 +)</td></tr>+<tr valign="top"><td align="right">(+ __)</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> (+ _0)</td></tr>+<tr valign="top"><td align="right">(__{f3 = 2}) Ctor</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> (_0{f3 = 2})) Ctor</td></tr>+<tr valign="top"><td align="right">__{f3 = 2} $ Ctor</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> _0{f3 = 2}) $ Ctor</td></tr>+<tr valign="top"><td align="right">(Ctor{f3 = __}) 2</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> (Ctor{f3 = _0})) 2</td></tr>+<tr valign="top"><td align="right">Ctor{f3 = __} $ 2</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> Ctor{f3 = _0}) $ 2</td></tr>+<tr valign="top"><td align="right">[__ ..]</td><td> = </td><td>\ _0 <span style="font-family: monospace;">-></span> [_0 ..]</td></tr>+<tr valign="top"><td align="right">[__ ..] 3</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> [_0 ..]) 3</td></tr>+<tr valign="top"><td align="right">[__ .. __] 3 5</td><td> = </td><td>(\ _0 _1 <span style="font-family: monospace;">-></span> [_0 .. _1]) 3 5</td></tr>+<tr valign="top"><td align="right">[__, __ ..] 3 5</td><td> = </td><td>(\ _0 _1 <span style="font-family: monospace;">-></span> [_0, _1 ..]) 3 5</td></tr>+<tr valign="top"><td align="right">[__, __ .. __] 3 5 8</td><td> = </td><td>(\ _0 _1 _2 <span style="font-family: monospace;">-></span> [_0, _1 .. _2]) 3 5 8</td></tr>+<tr valign="top"><td align="right">[f __ x | x <span style="font-family: monospace;"><-</span> [1 .. 3]] 2</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> [f _0 x | x <span style="font-family: monospace;"><-</span> [1 .. 3]]) 2</td></tr>+<tr valign="top"><td align="right">(__ :: Int <span style="font-family: monospace;">-></span> Int) 2</td><td> = </td><td>(\ _0 <span style="font-family: monospace;">-></span> _0 :: Int <span style="font-family: monospace;">-></span> Int) 2</td></tr>+</table><br />+<br />+</body></html>
FilesAndParsing.hs view
@@ -1,17 +1,16 @@ --- Package: freesect-0.7+-- Package: freesect-0.8 -- Description: Extend Haskell to support free sections -- Example: zipWith (f __ b __ d) as cs -- Author: Andrew Seniuk <rasfar@gmail.com> -- Date: March 11, 2012--- License: BSD3 (./LICENCE)+-- License: BSD3 (./LICENSE) -- Executable: freesect -- Usage: See accompanying files 000-readme and z {-# LANGUAGE CPP #-} --- CPP definitions are now set using compiler options; see ./z and ./ile.--- #define ANNOTATED 0+-- CPP definitions are set using compiler options; see ./z and ./ile. module FilesAndParsing where @@ -56,7 +55,7 @@ dconts <- getDirectoryContents pathname cwd <- getCurrentDirectory let- dconts' = filter isDot dconts+ dconts' = filter isHS dconts pathname' = pathname ++ "/" dconts'' = map (pathname'++) dconts' dconts''' = map (removeDotPathComponent . makeAbsolute cwd) dconts''@@ -84,8 +83,8 @@ | head pname == '/' = pname -- already absolute | otherwise = pfx ++ "/" ++ pname - isDot :: String -> Bool- isDot s+ isHS :: String -> Bool+ isHS s | length s < 4 = False | (take 3 $ reverse s) == "sh." = True | otherwise = False
+ FreeSect.hs view
@@ -0,0 +1,370 @@++-- Package: freesect-0.8+-- Description: Extend Haskell to support free sections+-- Example: zipWith (f __ b __ d) as cs+-- Author: Andrew Seniuk <rasfar@gmail.com>+-- Date: March 11, 2012+-- License: BSD3 (./LICENSE)+-- Executable: freesect+-- Usage: See accompanying files 000-readme and z++{-# LANGUAGE CPP #-} -- just a couple #if 0/1's+{- # LANGUAGE DeriveDataTypeable #-} -- not needed!+{- # LANGUAGE FlexibleContexts #-} -- only needed in FreeSectAnnotated.hs+{- # LANGUAGE MultiParamTypeClasses #-}+{- # LANGUAGE RankNTypes #-} -- needed for the path accumulators+{- # LANGUAGE ExistentialQuantification #-}+{- # LANGUAGE GADTs #-}+{- # LANGUAGE ScopedTypeVariables #-} -- needed for a pattern type sig++{- # NOINLINE fs_warn_flaw #-}++-- CPP definitions are set using compiler options; see ./z and ./ile.++ module FreeSect(fs_module) where++ import Data.Data(Data,gmapQi)+ import Data.Generics.Aliases(mkQ,mkT,mkM)+ import Data.Generics.Schemes(everywhere,everywhereM,gcount)+--import Data.Generics -- this suffices to import all the above++ import Control.Monad.State++ import System.IO.Unsafe(unsafePerformIO) -- warning message to stderr+ import System.IO(hFlush,stderr,hPutStr)+--import Data.IORef(IORef,newIORef)++ import HSE++ import Util++--------------------------------------------------------------------------------++ -- No type signatures are needed anywhere in this file (confirmed),+ -- but in FreeSectAnnotated some /are/ needed.++ -- Why does GHC complain of pattern matches overlapping in some of+ -- the generic transformers, but not all? The code structure is+ -- completely analogous so far as I can see.++ -- :: Module -> Module always, at present+--fs_module :: Data a => a -> a -- typesig not nec.+ fs_module m0 = m5+ where+ -- It's a bit annoying, but GuardedRhs and UnGuardedRhs are+ -- not constructors of the same data type, so we cannot use+ -- a single generic traversal to handle both. Could the+ -- duplication be avoided?+ m1 = fs_warn_flaw m0 -- check/warn re. <ski>'s flaw+ m2 = fs_unguarded_rhss m1 -- translate UnGuardedRhs's+ m3 = fs_guarded_rhss m2 -- translate GuardedRhs's+ m4 = fs_error_if_any_remain m3 -- error if any freesects remain+ m5 = fs_cleanup m4 -- remove some redundant Paren's++--fs_warn_flaw :: Data a => a -> a -- unnec.+ fs_warn_flaw m = m'+ where+ m' = everywhere (mkT step) m+-- step :: Exp -> Exp -- unnec.+ step x@(App p@(Paren (App FSWildcard _)) _) = warning True p x+ step x@(App p@(Paren (App _ FSWildcard)) _) = warning False p x+ step x = x+-- warning :: Data a => Bool -> a -> a -> a -- unnec.+ warning b p x = unsafePerformIO+ $ do hPutStr stderr $ warning_message b p x+ hFlush stderr+ return x+ warning_message b p x+ = "Warning:\n"+ ++ " Inferring free section context of loose wildcard(s) occurring\n"+ ++ " in redundantly-parenthesised application\n"+ ++ " " ++ prettyPrint p ++ "\n"+ ++ " in the expression\n"+ ++ " " ++ prettyPrint x ++ "\n"+ ++ ( if b then " This means for e.g. that (f __) y is rewritten to (\\x->f x) y.\n" else " This means for e.g. that (__ x) y is rewritten to (\\f->f x) y.\n" ) -- parentheses are really key here...+ ++ " If this is not what you want, remove the redundant parentheses\n"+ ++ " or use explicit _[...]_ free section context syntax.\n"+ ++ " (Compile freesect with ANNOTATED=1 to get location info.)\n"++ -- :: Module -> Module always, at present+--fs_unguarded_rhss :: Data a => a -> a -- typesig not nec.+ fs_unguarded_rhss m = m''+ where+ m' = everywhere (mkT step1) m -- explicitly _[...]_ grouped freesects+ m'' = everywhere (mkT step2) m' -- remaining __'s get inferred context+-- step1 :: Rhs -> Rhs -- unnec.+ step1 (UnGuardedRhs e) = UnGuardedRhs e'+ where e' = fs_rhs_exp fresh e+ step1 x = x+-- step2 :: Rhs -> Rhs -- unnec.+ step2 x@(UnGuardedRhs e)+ | still_fsss = UnGuardedRhs e''+ | otherwise = x+ where+ still_fsss = 0 < gcount (False `mkQ` p) x+-- p :: Exp -> Bool+ p FSWildcard = True+ p _ = False+ e'' = fs_rhs_exp fresh e'+ e' = Paren e+ step2 x = x+ fresh = fs_fresh_name m++-- Unfortunate about the cloning here (see comment heading fs_module above).+ -- :: Module -> Module always, at present+--fs_guarded_rhss :: Data a => a -> a -- typesig not nec.+ fs_guarded_rhss m = m''+ where+ m' = everywhere (mkT step1) m -- explicitly _[...]_ grouped freesects+ m'' = everywhere (mkT step2) m' -- remaining __'s get inferred context+-- step1 :: GuardedRhs -> GuardedRhs -- unnec.+ step1 (GuardedRhs srcLoc slst e) = GuardedRhs srcLoc slst e'+ where e' = fs_rhs_exp fresh e+ step1 x = x+-- step2 :: GuardedRhs -> GuardedRhs -- unnec.+ step2 x@(GuardedRhs srcLoc slst e)+ | still_fsss = GuardedRhs srcLoc slst e''+ | otherwise = x+ where+ still_fsss = 0 < gcount (False `mkQ` p) x+-- p :: Exp -> Bool+ p FSWildcard = True+ p _ = False+ e'' = fs_rhs_exp fresh e'+ e' = Paren e+ step2 x = x+ fresh = fs_fresh_name m++ -- :: Module -> Module always, at present+--fs_error_if_any_remain :: Data a => a -> a -- typesig not nec.+ fs_error_if_any_remain m = m'+ where+ m' | still_fsss = error "Free sections can only occur in RHS Exp contexts."+ | otherwise = m+ still_fsss = 0 < gcount (False `mkQ` p) m+-- p :: Exp -> Bool+ p FSWildcard = True+-- p (FSContext _) = True -- dealt with subsequently in fs_cleanup+ p _ = False++ -- :: Module -> Module always, at present+--fs_cleanup :: Data a => a -> a -- typesig not nec.+ fs_cleanup m0 = m3+ where+ m1 = everywhere (mkT step1) m0 -- for the Rhs's (un-guarded)+ m2 = everywhere (mkT step2) m1 -- for the GuardedRhs's+ m3 = everywhere (mkT step3) m2 -- for remaining FSContext -> Paren+-- step1 :: Rhs -> Rhs -- unnec.+ step1 (UnGuardedRhs (FSContext e)) = UnGuardedRhs e+#if CLEAN_EXTRANEOUS_GROUPINGS+ step1 (UnGuardedRhs+ (InfixApp+ (FSContext e1)+ (QVarOp (UnQual (Symbol "$")))+ e2))+ = UnGuardedRhs+ (App+ (Paren e1)+ e2)+#endif+ step1 x = x+-- step2 :: GuardedRhs -> GuardedRhs -- unnec.+ step2 x@(GuardedRhs srcLoc slst (FSContext e)) = GuardedRhs srcLoc slst e+#if CLEAN_EXTRANEOUS_GROUPINGS+ step2 (GuardedRhs srcLoc slst+ (InfixApp+ (FSContext e1)+ (QVarOp (UnQual (Symbol "$")))+ e2))+ = GuardedRhs srcLoc slst+ (App+ (Paren e1)+ e2)+#endif+ step2 x = x+-- step3 :: Exp -> Exp -- once was nec. but not now?+ step3 (FSContext e) = Paren e+ step3 x = x++--------------------------------------------------------------------------------++ -- Actually perform freesect translations in the immediate subexpression+ -- of a given RHS in the AST. Since the caller is itself a bottom-up+ -- generic traversal, nested freesects will get rewritten before+ -- enclosing freesects are processed.+ -- :: String -> Exp -> Exp+--fs_rhs_exp :: Data a => String -> a -> a -- typesig not nec.+ fs_rhs_exp fresh rhs_top_exp = rhs_top_exp''+ where+ rhs_top_exp' = everywhere (mkT step) rhs_top_exp+ rhs_top_exp'' | num_fss_remaining > 0 = everywhere (mkT step2) rhs_top_exp'+ | otherwise = rhs_top_exp'+-- FSContext is the grouping node in the AST produced by freesect _[ ]_ syntax.+-- The default context inferencing cases follow this explicit FSContext case.+-- The Exp -> Exp type sig for step (though it works) is not needed here...+-- step :: Data a => a -> a -- ...although this one won't work.+ step x@(FSContext e) = fs_lambda_old ps' x'+ where (x',(ps,_)) = fs_name_slots fresh x+ ps' = reverse ps+#if 0+-- Just a test of generic power of SYB. A single traversal is generic, but+-- only permits transformation of nodes of a single specific type. The above+-- case is Exp -> Exp, while this is Decl -> Decl.+ step x@(DefaultDecl srcLoc ts) = fs_lambda [] x -- quick test+#endif+ step x = x+ num_fss_remaining = gcount (False `mkQ` p) rhs_top_exp'+-- p :: Exp -> Bool+ p FSWildcard = True+ p _ = False+ -- Default context inference works as follows:+ -- The (semilattice) join of all unbracketed __'s in a RHS is found.+ -- Then, the innermost enclosing Paren or infix $ determines the context,+ -- or -- if neither exists -- the whole RHS is taken as context.+ -- (Later: Added list braces (list enumerations and comprehensions) to+ -- the set of delimiters. This was motivated by consideration of+ -- primitives.html, but may need reconsideration when see more+ -- real-world examples.)+ --+ -- Would prefer to use SYB "everywhereBut" or "something", to stop+ -- searching farther, but ... would need an "everywhereButM" I think,+ -- since need to pass on the info that an amenable Paren+ -- has already been found.+-- step2 :: Exp -> Exp+ step2 x@(Paren e)+ | num_fss_remaining == gcount (False `mkQ` p) e+ = x'_+ | otherwise+ = x+ where+ -- (We safely discarded the Paren from the AST since FSContext will+ -- give Paren grouping behaviour in addition to freesect contexting.)+ x_ = FSContext e+-- x_ = x+ (x',(ps,_)) = fs_name_slots fresh x_+ ps' = reverse ps+ x'_ = fs_lambda_old ps' x'+ step2 x@(InfixApp e1 qop e2)+ | not good_op = x+ | num_fss_x < num_fss_remaining = x+ | num_fss_e2 == 0 = InfixApp e1'_ qop e2+ | num_fss_e1 == 0 = InfixApp e1 qop e2'_+ | otherwise = x'_+ where+ e1_ = FSContext e1+ e2_ = FSContext e2+ x_ = FSContext x+ good_op = case qop of+ QVarOp (UnQual (Symbol "$")) -> True+ _ -> False+ (e1',(ps1,_)) = fs_name_slots fresh e1_+ ps1' = reverse ps1+ (e2',(ps2,_)) = fs_name_slots fresh e2_+ ps2' = reverse ps2+ (x',(ps,_)) = fs_name_slots fresh x_+ ps' = reverse ps+ e1'_ = fs_lambda_old ps1' e1'+ e2'_ = fs_lambda_old ps2' e2'+ x'_ = fs_lambda_old ps' x'+ num_fss_e1 = gcount (False `mkQ` p) e1+ num_fss_e2 = gcount (False `mkQ` p) e2+ num_fss_x = num_fss_e1 + num_fss_e2+-- num_fss_x = gcount (False `mkQ` p) x+ -- These are simpler, since we are just wrapping the node in FSContext+ -- and calling the fs_lambda transformer.+ step2 x@(List _) = process x+ step2 x@(EnumFrom _) = process x+ step2 x@(EnumFromTo _ _) = process x+ step2 x@(EnumFromThen _ _) = process x+ step2 x@(EnumFromThenTo _ _ _) = process x+ step2 x@(ListComp e slst) = process x+ step2 x = x+ process x+ | num_fss_remaining == gcount (False `mkQ` p) x+ = x'_+ | otherwise+ = x+ where+ x_ = FSContext x+ x'_ = fs_lambda_old ps' x'+ (x',(ps,_)) = fs_name_slots fresh x_+ ps' = reverse ps++ -- Actually rewrite the passed Exp branch as a Lambda. The argument is,+ -- at least at present, always an FSContext, but any Exp branch would be+ -- treated analogously without changing fs_lambda.+ -- Note that the Lambda itself is wrapped in a Paren; this does not+ -- change the semantics of the AST, but is necessary in general to+ -- preserve the semantics when pretty-printing as lexical sourcecode.+ -- :: [String] -> Exp -> Exp always, at present+--fs_lambda :: Data a => [String] -> a -> a -- must NOT give this one!+--fs_lambda :: [String] -> Exp -> Exp -- unnec.+ fs_lambda ps_lambda e_lambda+-- XXX See fs_lambda_old for what we should do here now...+ | null ps_lambda+ = error $ "Error: Free section contains no wildcards.\n"+ ++ "(Source location unavailable; try compiling freesect "+ ++ "with ANNOTATED set to 1.)\n"+ | otherwise = lambda+ where+ lambda = Paren $ Lambda srcloc ps_lambda' e_lambda''+ ps_lambda' = map (\x->(PVar (Ident x))) ps_lambda+ e_lambda'' = e_lambda+-- e_lambda'@(FSContext e) = e_lambda+-- e_lambda'' = e+ srcloc = SrcLoc "" 0 0++ -- :: [String] -> Exp -> Exp always, at present+--fs_lambda_old :: Data a => [String] -> a -> a -- must NOT give this one!+--fs_lambda_old :: [String] -> Exp -> Exp -- unnec.+ fs_lambda_old ps_lambda e_lambda+-- Now, rather than report the error, we silently convert them+-- to Paren's. No harm is done with this interpretation (it+-- is natural), and it allows us to keep the FSContext nodes+-- around until a post-translation cleanup where they are made use of.+ | null ps_lambda+#if 1+ = FSContext e_lambda+#else+ = error $ "Error: Free section contains no wildcards.\n"+ ++ "(Source location unavailable; try compiling freesect "+ ++ "with ANNOTATED set to 1.)\n"+#endif+ | otherwise = lambda+ where+ -- The idea with leaving the FSContext's is, we can use+ -- them as markers to indicate where the rewrites happened+ -- (i.e. which Lambda's are due to freesect rewrites)+ -- and, in fs_clean, can use this to make the rewritten+ -- code a little bit cleaner (removing superfluous groupings+ -- or $ opertators).+ lambda = FSContext $ Lambda srcloc ps_lambda' e_lambda''+-- lambda = Paren $ Lambda srcloc ps_lambda' e_lambda''+ ps_lambda' = map (\x->(PVar (Ident x))) ps_lambda+ e_lambda'@(FSContext e) = e_lambda+ e_lambda'' = e+ srcloc = SrcLoc "" 0 0++ showSLorSSI (SrcLoc n l c)+ = n ++ ": line=" ++ show l ++ " col=" ++ show c++--------------------------------------------------------------------------------++ -- We need to construct the fresh names in this recursion anyway, so+ -- may as well collect them rather than recompute them in the caller,+ -- although we could because they are canonically constructable from+ -- fresh and n, the Int part of the state.+ -- Perhaps ironically, I don't like using partially-point-free function+ -- declarations like this, but I couldn't figure out what to do with+ -- the second parameter if I made it explicit!+--fs_name_slots :: Data a => String -> a -> (a,([String],Int)) -- not needed+ fs_name_slots fresh = flip runState ([],0) . everywhereM (mkM step)+ where+-- step :: MonadState ([String],Int) m => Exp -> m Exp -- unnec.+ step FSWildcard+ = do (ss,n) <- get+ let s = fresh ++ show n+ put ((s:ss),(1+n))+ return $ Var $ UnQual $ Ident $ s+ step x = return x+
+ FreeSectAnnotated.hs view
@@ -0,0 +1,409 @@++-- Package: freesect-0.8+-- Description: Extend Haskell to support free sections+-- Example: zipWith (f __ b __ d) as cs+-- Author: Andrew Seniuk <rasfar@gmail.com>+-- Date: March 11, 2012+-- License: BSD3 (./LICENSE)+-- Executable: freesect+-- Usage: See accompanying files 000-readme and z++{-# LANGUAGE CPP #-} -- just a couple #if 0/1's+{- # LANGUAGE DeriveDataTypeable #-} -- not needed!+{-# LANGUAGE FlexibleContexts #-} -- needed for one of the type sigs+{- # LANGUAGE MultiParamTypeClasses #-}+{- # LANGUAGE RankNTypes #-} -- needed for the path accumulators+{- # LANGUAGE ExistentialQuantification #-}+{- # LANGUAGE GADTs #-}+{- # LANGUAGE ScopedTypeVariables #-} -- needed for a pattern type sig++{- # NOINLINE showSSI #-}+{- # NOINLINE FreeSectAnnotated.showSSI #-}++ module FreeSectAnnotated where++ import Data.Data(Data,gmapQi)+ import Data.Generics.Aliases(mkQ,mkT,mkM)+ import Data.Generics.Schemes(everywhere,everywhereM,gcount)+--import Data.Generics -- this suffices to import all the above++ import Control.Monad.State++ import System.IO.Unsafe(unsafePerformIO) -- warning message to stderr+ import System.IO(hFlush,stderr,hPutStr)+ import System.IO(putStrLn)+--import Data.IORef(IORef,newIORef)++ import HSE.Annotated++ import Util++--------------------------------------------------------------------------------++ -- Why does GHC complain of pattern matches overlapping in some of+ -- the generic transformers, but not all? The code structure is+ -- completely analogous so far as I can see.++ -- :: Module -> Module always, at present+--fs_module :: Data a => a -> a -- typesig not nec.+ fs_module m0 = m5+ where+ -- It's a bit annoying, but GuardedRhs and UnGuardedRhs are+ -- not constructors of the same data type, so we cannot use+ -- a single generic traversal to handle both. Could the+ -- duplication be avoided?+ m1 = fs_warn_flaw m0 -- check/warn re. <ski>'s flaw+ m2 = fs_unguarded_rhss m1 -- translate UnGuardedRhs's+ m3 = fs_guarded_rhss m2 -- translate GuardedRhs's+ m4 = fs_error_if_any_remain m3 -- error if any freesects remain+ m5 = fs_cleanup m4 -- remove some redundant Paren's++ -- :: Module -> Module always, at present+--fs_warn_flaw :: Data a => a -> a -- unnec.+ fs_warn_flaw m = m'+ where+ m' = everywhere (mkT step) m+-- step :: Exp SrcSpanInfo -> Exp SrcSpanInfo -- unnec.+ step x@(App _ p@(Paren ssi (App _ (FSWildcard _) _)) _) = warning True ssi p x+ step x@(App _ p@(Paren ssi (App _ _ (FSWildcard _))) _) = warning False ssi p x+ step x = x+-- warning :: Data a => Bool -> SrcSpanInfo -> a -> a -> a -- unnec.+ warning b ssi p x = unsafePerformIO+ $ do+ hPutStr stderr $ warning_message b ssi p x+ hFlush stderr+ return x+ warning_message b ssi p x+ = showSSI ssi ++ " Warning:\n"+-- = (error $ showSSI ssi) ++ "\n"+ ++ " Inferring free section context of loose wildcard(s) occurring\n"+ ++ " in redundantly-parenthesised application\n"+ ++ " " ++ prettyPrint p ++ "\n"+ ++ " in the expression\n"+ ++ " " ++ prettyPrint x ++ "\n"+ ++ ( if b then " This means for e.g. that (f __) y is rewritten to (\\x->f x) y.\n" else " This means for e.g. that (__ x) y is rewritten to (\\f->f x) y.\n" ) -- parentheses are really key here...+ ++ " If this is not what you want, remove the redundant parentheses\n"+ ++ " or use explicit _[...]_ free section context syntax.\n"++ -- :: Module -> Module always, at present+--fs_unguarded_rhss :: Data a => a -> a -- typesig not nec.+ fs_unguarded_rhss m = m''+ where+ m' = everywhere (mkT step1) m -- explicitly _[...]_ grouped freesects+ m'' = everywhere (mkT step2) m' -- remaining __'s get inferred context+ step1 :: Rhs SrcSpanInfo -> Rhs SrcSpanInfo -- seems nec.+ step1 (UnGuardedRhs srcSpanInfo e) = UnGuardedRhs srcSpanInfo e'+ where e' = fs_rhs_exp fresh e+ step1 x = x+ step2 :: Rhs SrcSpanInfo -> Rhs SrcSpanInfo -- seems nec.+ step2 x@(UnGuardedRhs srcSpanInfo e)+ | still_fsss = UnGuardedRhs srcSpanInfo e''+ | otherwise = x+ where+ still_fsss = 0 < gcount (False `mkQ` p) x+ p :: Exp SrcSpanInfo -> Bool -- nec.+ p (FSWildcard _) = True+ p _ = False+ e'' = fs_rhs_exp fresh e'+ e' = Paren srcSpanInfo e+ step2 x = x+ fresh = fs_fresh_name m++-- Unfortunate about the cloning here (see comment heading fs_module above).+ -- :: Module -> Module always, at present+--fs_guarded_rhss :: Data a => a -> a -- typesig not nec.+ fs_guarded_rhss m = m''+ where+ m' = everywhere (mkT step1) m -- explicitly _[...]_ grouped freesects+ m'' = everywhere (mkT step2) m' -- remaining __'s get inferred context+ step1 :: GuardedRhs SrcSpanInfo -> GuardedRhs SrcSpanInfo -- seems nec.+ step1 (GuardedRhs srcSpanInfo slst e) = GuardedRhs srcSpanInfo slst e'+ where e' = fs_rhs_exp fresh e+ step1 x = x+ step2 :: GuardedRhs SrcSpanInfo -> GuardedRhs SrcSpanInfo -- seems nec.+ step2 x@(GuardedRhs srcSpanInfo slst e)+ | still_fsss = GuardedRhs srcSpanInfo slst e''+ | otherwise = x+ where+ still_fsss = 0 < gcount (False `mkQ` p) x+ p :: Exp SrcSpanInfo -> Bool -- nec.+ p (FSWildcard _) = True+ p _ = False+ e'' = fs_rhs_exp fresh e'+ e' = Paren srcSpanInfo e+ step2 x = x+ fresh = fs_fresh_name m++ -- :: Module -> Module always, at present+--fs_error_if_any_remain :: Data a => a -> a -- typesig not nec.+ fs_error_if_any_remain m = m'+ where+ m' | still_fsss = error "Free sections can only occur in RHS Exp contexts."+ | otherwise = m+ still_fsss = 0 < gcount (False `mkQ` p) m+ p :: Exp SrcSpanInfo -> Bool -- nec.+ p (FSWildcard _) = True+-- p (FSContext _ _) = True -- dealt with subsequently in fs_cleanup+ p _ = False++ -- :: Module -> Module always, at present+--fs_cleanup :: Data a => a -> a -- typesig not nec.+ fs_cleanup m0 = m3+ where+ m1 = everywhere (mkT step1) m0 -- for the Rhs's (un-guarded)+ m2 = everywhere (mkT step2) m1 -- for the GuardedRhs's+ m3 = everywhere (mkT step3) m2 -- for remaining FSContext -> Paren+ step1 :: Rhs SrcSpanInfo -> Rhs SrcSpanInfo -- seems nec.+ step1 (UnGuardedRhs srcSpanInfo (FSContext _ e)) = UnGuardedRhs srcSpanInfo e+#if CLEAN_EXTRANEOUS_GROUPINGS+ step1 (UnGuardedRhs ssi+ (InfixApp _+ (FSContext _ e1)+ (QVarOp _ (UnQual _ (Symbol _ "$")))+ e2))+ = UnGuardedRhs ssi+ (App ssi+ (Paren ssi e1)+ e2)+#endif+ step1 x = x+ step2 :: GuardedRhs SrcSpanInfo -> GuardedRhs SrcSpanInfo -- seems nec.+ step2 x@(GuardedRhs srcSpanInfo slst (FSContext _ e)) = GuardedRhs srcSpanInfo slst e+#if CLEAN_EXTRANEOUS_GROUPINGS+ step2 (GuardedRhs ssi slst+ (InfixApp _+ (FSContext _ e1)+ (QVarOp _ (UnQual _ (Symbol _ "$")))+ e2))+ = GuardedRhs ssi slst+ (App ssi+ (Paren ssi e1)+ e2)+#endif+ step2 x = x+ step3 :: Exp SrcSpanInfo -> Exp SrcSpanInfo -- seems nec.+ step3 (FSContext ssi e) = Paren ssi e+ step3 x = x++--------------------------------------------------------------------------------++ -- Actually perform freesect translations in the immediate subexpression+ -- of a given RHS in the AST. Since the caller is itself a bottom-up+ -- generic traversal, nested freesects will get rewritten before+ -- enclosing freesects are processed.+ -- :: String -> Exp -> Exp+--fs_rhs_exp :: Data a => String -> a -> a -- typesig not nec.+ fs_rhs_exp fresh rhs_top_exp = rhs_top_exp''+ where+ rhs_top_exp' = everywhere (mkT step) rhs_top_exp+ rhs_top_exp'' | num_fss_remaining > 0 = everywhere (mkT step2) rhs_top_exp'+ | otherwise = rhs_top_exp'+-- FSContext is the grouping node in the AST produced by freesect _[ ]_ syntax.+-- The default context inferencing cases follow this explicit FSContext case.+-- The Exp -> Exp type sig for step (though it works) is not needed here...+-- step :: Data a => a -> a -- ...although this one won't work.+ step x@(FSContext srcSpanInfo e) = fs_lambda_old ps' x'+ where (x',(ps,_)) = fs_name_slots fresh x+ ps' = reverse ps+#if 0+-- Just a test of generic power of SYB. A single traversal is generic, but+-- only permits transformation of nodes of a single specific type. The above+-- case is Exp -> Exp, while this is Decl -> Decl.+ step x@(DefaultDecl srcSpanInfo ts) = fs_lambda [] x -- quick test+#endif+ step x = x+ num_fss_remaining = gcount (False `mkQ` p) rhs_top_exp'+ p :: Exp SrcSpanInfo -> Bool -- nec.+ p (FSWildcard _) = True+ p _ = False+ -- Default context inference works as follows:+ -- The (semilattice) join of all unbracketed __'s in a RHS is found.+ -- Then, the innermost enclosing Paren or infix $ determines the context,+ -- or -- if neither exists -- the whole RHS is taken as context.+ -- (Later: Added list braces (list enumerations and comprehensions) to+ -- the set of delimiters. This was motivated by consideration of+ -- primitives.html, but may need reconsideration when see more+ -- real-world examples.)+ --+ -- Would prefer to use SYB "everywhereBut" or "something", to stop+ -- searching farther, but ... would need an "everywhereButM" I think,+ -- since need to pass on the info that an amenable Paren+ -- has already been found.+-- Strangely the type sig not needed here...+-- step2 :: Exp SrcSpanInfo -> Exp SrcSpanInfo+ -- | Paren l (Exp l)+ step2 x@(Paren srcSpanInfo e)+ | num_fss_remaining == gcount (False `mkQ` p) e+ = x'_+ | otherwise+ = x+ where+ x_ = FSContext srcSpanInfo e+-- x_ = x+ (x',(ps,_)) = fs_name_slots fresh x_+ ps' = reverse ps+ x'_ = fs_lambda_old ps' x'+ -- | InfixApp l (Exp l) (QOp l) (Exp l)+ step2 x@(InfixApp srcSpanInfo e1 qop e2)+ | not good_op = x+ | num_fss_x < num_fss_remaining = x+ | num_fss_e2 == 0 = InfixApp srcSpanInfo e1'_ qop e2+ | num_fss_e1 == 0 = InfixApp srcSpanInfo e1 qop e2'_+ | otherwise = x'_+ where+ e1_ = FSContext srcSpanInfo e1+ e2_ = FSContext srcSpanInfo e2+ x_ = FSContext srcSpanInfo x+ -- May want to broaden this category? remember, it's a trade off,+ -- if you use an op for a freesect context delimiter, it can't+ -- be used inside a freesect with defaulting context.+ -- To see why $ was chosen, check out the S23.hs test file.+ good_op = case qop of+ QVarOp _ (UnQual _ (Symbol _ "$")) -> True+ _ -> False+ (e1',(ps1,_)) = fs_name_slots fresh e1_+ ps1' = reverse ps1+ (e2',(ps2,_)) = fs_name_slots fresh e2_+ ps2' = reverse ps2+ (x',(ps,_)) = fs_name_slots fresh x_+ ps' = reverse ps+ e1'_ = fs_lambda_old ps1' e1'+ e2'_ = fs_lambda_old ps2' e2'+ x'_ = fs_lambda_old ps' x'+ num_fss_e1 = gcount (False `mkQ` p) e1+ num_fss_e2 = gcount (False `mkQ` p) e2+ num_fss_x = num_fss_e1 + num_fss_e2+-- num_fss_x = gcount (False `mkQ` p) x+ -- These are simpler, since we are just wrapping the node in FSContext+ -- and calling the fs_lambda transformer.+ -- | List l [Exp l]+ step2 x@(List srcSpanInfo _) = process srcSpanInfo x+ -- | EnumFrom l (Exp l)+ step2 x@(EnumFrom srcSpanInfo _) = process srcSpanInfo x+ -- | EnumFromTo l (Exp l) (Exp l)+ step2 x@(EnumFromTo srcSpanInfo _ _) = process srcSpanInfo x+ -- | EnumFromThen l (Exp l) (Exp l)+ step2 x@(EnumFromThen srcSpanInfo _ _) = process srcSpanInfo x+ -- | EnumFromThenTo l (Exp l) (Exp l) (Exp l)+ step2 x@(EnumFromThenTo srcSpanInfo _ _ _) = process srcSpanInfo x+ -- | ListComp l (Exp l) [(QualStmt l)]+ step2 x@(ListComp srcSpanInfo e slst) = process srcSpanInfo x+ -- | ParComp l (Exp l) [[(QualStmt l)]]+ -- HSE generates syntax errors when try to use this extension.+ step2 x = x++ process ssi x+ | num_fss_remaining == gcount (False `mkQ` p) x+ = x'_+ | otherwise+ = x+ where+ x_ = FSContext ssi x+ x'_ = fs_lambda_old ps' x'+ (x',(ps,_)) = fs_name_slots fresh x_+ ps' = reverse ps++ -- Actually rewrite the passed Exp branch as a Lambda. The argument is,+ -- at least at present, always an FSContext, but any Exp branch would be+ -- treated analogously without changing fs_lambda.+ -- Note that the Lambda itself is wrapped in a Paren; this does not+ -- change the semantics of the AST, but is necessary in general to+ -- preserve the semantics when pretty-printing as lexical sourcecode.+ -- :: [String] -> Exp -> Exp always, at present+--fs_lambda :: Data a => [String] -> a -> a -- must NOT give this one!+-- Strangely the type sig not needed here...+--fs_lambda :: [String] -> Exp SrcSpanInfo -> Exp SrcSpanInfo+ fs_lambda ps_lambda e_lambda+-- XXX See fs_lambda_old for what we should do here now...+ | null ps_lambda+ = error $ "Error: Free section contains no wildcards.\n"+ ++ showSSI ssi+ | otherwise = lambda+ where+ lambda = Paren ssi $ Lambda ssi ps_lambda' e_lambda''+ ps_lambda' = map (\x->(PVar ssi (Ident ssi x))) ps_lambda+ e_lambda'' = e_lambda+ ssi = head $ gmapQi 0 ([] `mkQ` ((\x->[x])::SrcSpanInfo->[SrcSpanInfo])) e_lambda+-- e_lambda'@(FSContext ssi e) = e_lambda+-- e_lambda'' = e++ -- :: [String] -> Exp -> Exp always, at present+--fs_lambda_old :: Data a => [String] -> a -> a -- must NOT give this one!+-- Strangely the type sig not needed here...+-- ...But it /is/ when changed the "null ps_lambda" case.+ fs_lambda_old :: [String] -> Exp SrcSpanInfo -> Exp SrcSpanInfo+ fs_lambda_old ps_lambda e_lambda+-- Now, rather than report the error, we silently convert them+-- to Paren's. No harm is done with this interpretation (it+-- is natural), and it allows us to keep the FSContext nodes+-- around until a post-translation cleanup where they are made use of.+ | null ps_lambda+#if 1+ = FSContext ssi e_lambda+#else+ = error $ "Error: Free section contains no wildcards.\n"+ ++ showSSI ssi+#endif+ | otherwise = lambda+ where+ -- The idea with leaving the FSContext's is, we can use+ -- them as markers to indicate where the rewrites happened+ -- (i.e. which Lambda's are due to freesect rewrites)+ -- and, in fs_clean, can use this to make the rewritten+ -- code a little bit cleaner (removing superfluous groupings+ -- or $ opertators).+ lambda = FSContext ssi $ Lambda ssi ps_lambda' e_lambda''+-- lambda = Paren ssi $ Lambda ssi ps_lambda' e_lambda''+ ps_lambda' = map (\x->(PVar ssi (Ident ssi x))) ps_lambda+ e_lambda'@(FSContext ssi e) = e_lambda+ e_lambda'' = e++ showSSI (SrcSpanInfo si _)+#if 0+#elif 0+ -- Prints, for example, "S28.hs:6:0: 7" (sans quotes), which is wrong.+ -- We expect "S28.hs:6:7" (sans quotes). This wierdness is somehow+ -- connected to the use from unsafePerformIO, since "error $ showSSI ssi"+ -- prints the expected output.+ = fileName si ++ ":" ++ show (startLine si)+ ++ ":" ++ show (startColumn si)+#elif 1+ -- prints correctly!+ = fileName si ++ ":\0" ++ show (startLine si)+ ++ ":" ++ show (startColumn si)+#elif 0+ -- prints correctly (except for the extra space...)+ = fileName si ++ ": " ++ show (startLine si)+ ++ ":" ++ show (startColumn si)+#elif 0+ -- (prints fine, but we prefer the terser, standard GHC location designator)+ = fileName si ++ ": line=" ++ show (startLine si)+ ++ " col=" ++ show (startColumn si)+#endif++--------------------------------------------------------------------------------++ -- We need to construct the fresh names in this recursion anyway, so+ -- may as well collect them rather than recompute them in the caller,+ -- although we could because they are canonically constructable from+ -- fresh and n, the Int part of the state.+ -- Perhaps ironically, I don't like using partially-point-free function+ -- declarations like this, but I couldn't figure out what to do with+ -- the second parameter if I made it explicit!+--fs_name_slots :: Data a => String -> a -> (a,([String],Int)) -- not needed+ fs_name_slots fresh = flip runState ([],0) . everywhereM (mkM step)+ where+-- Type signature necessary, and it seems that -XFlexibleContexts is+-- needed for it to be written?+-- step :: MonadState m => Exp SrcSpanInfo -> m (Exp SrcSpanInfo)+-- step :: MonadState s m => Exp SrcSpanInfo -> m (Exp SrcSpanInfo)+-- step :: MonadState (a,b) m => Exp SrcSpanInfo -> m (Exp SrcSpanInfo)+-- step :: MonadState ([a],b) m => Exp SrcSpanInfo -> m (Exp SrcSpanInfo)+ step :: MonadState ([String],Int) m => Exp SrcSpanInfo -> m (Exp SrcSpanInfo)+ step (FSWildcard srcSpanInfo)+ = do (ss,n) <- get+ let s = fresh ++ show n+ put ((s:ss),(1+n))+ return $ Var srcSpanInfo $ UnQual srcSpanInfo $ Ident srcSpanInfo s+ step x = return x+
HSE/Annotated/Build.hs view
@@ -50,7 +50,7 @@ listE, -- :: [Exp] -> Exp eList, -- :: Exp peList, -- :: Pat- fscontext, -- :: Exp -> Exp+ fsContext, -- :: Exp -> Exp paren, -- :: Exp -> Exp pParen, -- :: Pat -> Pat qualStmt, -- :: Exp -> Stmt@@ -58,7 +58,7 @@ letStmt, -- :: [Decl] -> Stmt binds, -- :: [Decl] -> Binds noBinds, -- :: Binds- freeSectSlot, -- :: Exp+ fsWildcard, -- :: Exp wildcard, -- :: Pat genNames, -- :: String -> Int -> [Name] @@ -216,8 +216,8 @@ peList l = PList l [] -- | Put FreeSect context around an expression.-fscontext :: l -> Exp l -> Exp l-fscontext = FSContext+fsContext :: l -> Exp l -> Exp l+fsContext = FSContext -- | Put parentheses around an expression. paren :: l -> Exp l -> Exp l@@ -248,8 +248,8 @@ noBinds l = binds l [] -- | FreeSect placeholder: @__@-freeSectSlot :: l -> Exp l-freeSectSlot = FreeSectSlot+fsWildcard :: l -> Exp l+fsWildcard = FSWildcard -- | The wildcard pattern: @_@ wildcard :: l -> Pat l
HSE/Annotated/ExactPrint.hs view
@@ -168,8 +168,8 @@ -- I'm not sure why'd need, but trying to follow Paren behaviour for Exp -- (because failed to get it working so far folloing XRPats etc.) -fscontextList :: (Annotated ast, ExactP ast) => [SrcSpan] -> [ast SrcSpanInfo] -> EP () -fscontextList = bracketList ("_[",",","]_") +fsContextList :: (Annotated ast, ExactP ast) => [SrcSpan] -> [ast SrcSpanInfo] -> EP () +fsContextList = bracketList ("_[",",","]_") parenList, squareList, curlyList :: (Annotated ast, ExactP ast) => [SrcSpan] -> [ast SrcSpanInfo] -> EP () parenList = bracketList ("(",",",")") @@ -1100,7 +1100,7 @@ instance ExactP Exp where exactP exp = case exp of Var l qn -> exactP qn - FreeSectSlot l -> printString "__" + FSWildcard l -> printString "__" IPVar l ipn -> exactP ipn Con l qn -> exactP qn Lit l lit -> exactP lit @@ -1159,7 +1159,7 @@ printSeq $ interleave (zip (map pos $ init pts) (map printString ("(": repeat ",")) ++ [(pos $ last pts, printString ")")]) (map (maybe (0,0) (pos . ann) &&& maybeEP exactPC) mexps) List l es -> squareList (srcInfoPoints l) es - FSContext l p -> fscontextList (srcInfoPoints l) [p] + FSContext l p -> fsContextList (srcInfoPoints l) [p] Paren l p -> parenList (srcInfoPoints l) [p] LeftSection l e qop -> case srcInfoPoints l of
HSE/Annotated/Simplify.hs view
@@ -334,7 +334,7 @@ sExp :: SrcInfo loc => Exp loc -> S.Exp sExp e = case e of Var _ qn -> S.Var (sQName qn) - FreeSectSlot _ -> S.FreeSectSlot + FSWildcard _ -> S.FSWildcard IPVar _ ipn -> S.IPVar (sIPName ipn) Con _ qn -> S.Con (sQName qn) Lit _ lit -> S.Lit (sLiteral lit)
HSE/Annotated/Syntax.hs view
@@ -689,7 +689,7 @@ -- | Haskell expressions. data Exp l = Var l (QName l) -- ^ variable- | FreeSectSlot l -- ^ FreeSect placeholder: @__@+ | FSWildcard l -- ^ FreeSect placeholder: @__@ | IPVar l (IPName l) -- ^ implicit parameter variable | Con l (QName l) -- ^ data constructor | Lit l (Literal l) -- ^ literal constant@@ -1362,7 +1362,7 @@ instance Functor Exp where fmap f e = case e of Var l qn -> Var (f l) (fmap f qn)- FreeSectSlot l -> FreeSectSlot (f l)+ FSWildcard l -> FSWildcard (f l) IPVar l ipn -> IPVar (f l) (fmap f ipn) Con l qn -> Con (f l) (fmap f qn) Lit l lit -> Lit (f l) (fmap f lit)
HSE/Build.hs view
@@ -50,7 +50,7 @@ listE, -- :: [Exp] -> Exp eList, -- :: Exp peList, -- :: Pat- fscontext, -- :: Exp -> Exp+ fsContext, -- :: Exp -> Exp paren, -- :: Exp -> Exp pParen, -- :: Pat -> Pat qualStmt, -- :: Exp -> Stmt@@ -58,7 +58,7 @@ letStmt, -- :: [Decl] -> Stmt binds, -- :: [Decl] -> Binds noBinds, -- :: Binds- freeSectSlot, -- :: Exp+ fsWildcard, -- :: Exp wildcard, -- :: Pat genNames, -- :: String -> Int -> [Name] @@ -216,8 +216,8 @@ peList = PList [] -- | Put FreeSect context around an expression.-fscontext :: Exp -> Exp-fscontext = FSContext+fsContext :: Exp -> Exp+fsContext = FSContext -- | Put parentheses around an expression. paren :: Exp -> Exp@@ -248,8 +248,8 @@ noBinds = binds [] -- | FreeSect placeholder: @__@-freeSectSlot :: Exp-freeSectSlot = FreeSectSlot+fsWildcard :: Exp+fsWildcard = FSWildcard -- | The wildcard pattern: @_@ wildcard :: Pat
HSE/InternalParser.hs view
@@ -5531,7 +5531,7 @@ happyReduction_363 happy_x_1 = case happyOutTok happy_x_1 of { (Loc happy_var_1 DoubleUnderscore) -> happyIn152- (FreeSectSlot (nIS happy_var_1)+ (FSWildcard (nIS happy_var_1) )} happyReduce_364 = happySpecReduce_1 141# happyReduction_364
HSE/InternalParser.ly view
@@ -1189,7 +1189,7 @@ > fexp :: { PExp L } > {- -- Can't get it to work (get compile errors on the produced .hs):-> : fexp '_' {% checkEnabled FreeSections >> return (App ($1 <> (nIS $2)) $1 (FreeSectSlot (nIS $2))) }+> : fexp '_' {% checkEnabled FreeSections >> return (App ($1 <> (nIS $2)) $1 (FSWildcard (nIS $2))) } > | fexp aexp { App ($1 <> $2) $1 $2 } > -} > : fexp aexp { App ($1 <> $2) $1 $2 }@@ -1254,12 +1254,12 @@ > -- I was unsuccessful in changing '__' to '_' -- tried moving the > -- production to various places, but always reduce/reduce conflicts... > -- For now, __ is fine.-> {- | '_' exp {% checkEnabled FreeSections >> return (FreeSectSlot (nIS $1)) $2 } -}+> {- | '_' exp {% checkEnabled FreeSections >> return (FSWildcard (nIS $1)) $2 } -} > -- GHC -F still checks with that all LANGUAGE pragmas are known to GHC, > -- which is unfortunate, as the whole point of the -F option is to > -- allow -- preprocessing (i.e. maybe the preprocessing strips it).-> | '__' { FreeSectSlot (nIS $1) }-> -- | '__' {% checkEnabled FreeSections >> return (FreeSectSlot (nIS $1)) }+> | '__' { FSWildcard (nIS $1) }+> -- | '__' {% checkEnabled FreeSections >> return (FSWildcard (nIS $1)) } > | '_' { WildCard (nIS $1) } > | '(' erpats ')' {% checkEnabled RegularPatterns >> return (Paren ($1 <^^> $3 <** [$1,$3]) $2) } > | '(|' sexps '|)' { SeqRP ($1 <^^> $3 <** ($1:reverse (snd $2) ++ [$3])) $ reverse (fst $2) }
HSE/Lexer.hs view
@@ -662,7 +662,7 @@ -- it would be nice to control that behaviour. No luck however, -- from here it looks like I'd need to invent a whole new token -- and make parallel edits through almost all teh HSE files as- -- for FreeSectSlot and FSContext. Can't use FSContext because+ -- for FSWildcard and FSContext. Can't use FSContext because -- it takes an Exp ... could make that a Maybe Exp or a [Exp] -- I guess, that would be one way... '_':'[':']':'_':_ -> do discard 4 >> lexStdToken
HSE/ParseSyntax.hs view
@@ -45,7 +45,7 @@ | ParComp l (PExp l) [[QualStmt l]] -- ^ parallel list comprehension | ExpTypeSig l (PExp l) (S.Type l) -- ^ expression type signature | AsPat l (Name l) (PExp l) -- ^ patterns only - | FreeSectSlot l -- ^ expressions only + | FSWildcard l -- ^ expressions only | WildCard l -- ^ patterns only | IrrPat l (PExp l) -- ^ patterns only @@ -136,7 +136,7 @@ ParComp l e qsss -> l ExpTypeSig l e t -> l AsPat l n e -> l - FreeSectSlot l -> l + FSWildcard l -> l WildCard l -> l IrrPat l e -> l PostOp l e op -> l @@ -201,7 +201,7 @@ ExpTypeSig l e t -> ExpTypeSig (f l) e t AsPat l n e -> AsPat (f l) n e - FreeSectSlot l -> FreeSectSlot (f l) + FSWildcard l -> FSWildcard (f l) WildCard l -> WildCard (f l) IrrPat l e -> IrrPat (f l) e PostOp l e op -> PostOp (f l) e op @@ -266,7 +266,7 @@ ExpTypeSig l e t -> ExpTypeSig (f l) (fmap f e) (fmap f t) AsPat l n e -> AsPat (f l) (fmap f n) (fmap f e) - FreeSectSlot l -> FreeSectSlot (f l) + FSWildcard l -> FSWildcard (f l) WildCard l -> WildCard (f l) IrrPat l e -> IrrPat (f l) (fmap f e) PostOp l e op -> PostOp (f l) (fmap f e) (fmap f op)
HSE/ParseUtils.hs view
@@ -516,7 +516,7 @@ checkExpr :: PExp L -> P (S.Exp L) checkExpr e = case e of Var l v -> return $ S.Var l v- FreeSectSlot l -> return (S.FreeSectSlot l)+ FSWildcard l -> return (S.FSWildcard l) IPVar l v -> return $ S.IPVar l v Con l c -> return $ S.Con l c Lit l lit -> return $ S.Lit l lit
HSE/Pretty.hs view
@@ -173,8 +173,8 @@ -- Simple Combining Forms ---fscontexts :: Doc -> Doc---fscontexts d = d >>= return . P.fscontexts+--fsContexts :: Doc -> Doc+--fsContexts d = d >>= return . P.fsContexts parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc parens d = d >>= return . P.parens brackets d = d >>= return . P.brackets@@ -182,9 +182,9 @@ quotes d = d >>= return . P.quotes doubleQuotes d = d >>= return . P.doubleQuotes ---fscontextsIf :: Bool -> Doc -> Doc---fscontextsIf True = fscontexts---fscontextsIf False = id+--fsContextsIf :: Bool -> Doc -> Doc+--fsContextsIf True = fsContexts+--fsContextsIf False = id parensIf :: Bool -> Doc -> Doc parensIf True = parens@@ -767,7 +767,7 @@ pretty (PrimDouble r) = double (fromRational r) <> text "##" instance Pretty Exp where- prettyPrec _ FreeSectSlot = text "__"+ prettyPrec _ FSWildcard = text "__" prettyPrec _ (Lit l) = pretty l -- lambda stuff prettyPrec p (InfixApp a op b) = parensIf (p > 2) $ myFsep [prettyPrec 2 a, pretty op, prettyPrec 1 b]@@ -800,7 +800,7 @@ prettyPrec _ (Tuple expList) = parenList . map pretty $ expList prettyPrec _ (TupleSection mExpList) = parenList . map (maybePP pretty) $ mExpList -- weird stuff--- prettyPrec _ (FSContext e) = fscontexts . pretty $ e+-- prettyPrec _ (FSContext e) = fsContexts . pretty $ e prettyPrec _ (FSContext e) = myFsep $ [text "_[", pretty e, text "]_"] prettyPrec _ (Paren e) = parens . pretty $ e prettyPrec _ (LeftSection e op) = parens (pretty e <+> pretty op)@@ -1595,7 +1595,7 @@ myFsep [pretty name <> char '@', char '~' <> pretty pat] pretty (P.AsPat _ name pat) = hcat [pretty name, char '@', pretty pat]- pretty (P.FreeSectSlot _) = text "__"+ pretty (P.FSWildcard _) = text "__" pretty (P.WildCard _) = char '_' pretty (P.IrrPat _ pat) = char '~' <> pretty pat pretty (P.PostOp _ e op) = pretty e <+> pretty op
HSE/Syntax.hs view
@@ -589,7 +589,7 @@ -- | Haskell expressions. data Exp = Var QName -- ^ variable- | FreeSectSlot -- ^ FreeSect placeholder: @__@+ | FSWildcard -- ^ FreeSect placeholder: @__@ | IPVar IPName -- ^ implicit parameter variable | Con QName -- ^ data constructor | Lit Literal -- ^ literal constant
Main.hs view
@@ -1,526 +1,76 @@ --- Package: freesect-0.7+-- Package: freesect-0.8 -- Description: Extend Haskell to support free sections -- Example: zipWith (f __ b __ d) as cs -- Author: Andrew Seniuk <rasfar@gmail.com> -- Date: March 11, 2012--- License: BSD3 (./LICENCE)+-- License: BSD3 (./LICENSE) -- Executable: freesect -- Usage: See accompanying files 000-readme and z -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-} -- needed for some of the type sigs. {-# LANGUAGE CPP #-}-{- # LANGUAGE MultiParamTypeClasses #-}-{- # LANGUAGE RankNTypes #-} -- needed for the path accumulators.-{- # LANGUAGE ExistentialQuantification #-}-{- # LANGUAGE GADTs #-}-{- # LANGUAGE ScopedTypeVariables #-} -- needed for a pattern type sig.+{- # LANGUAGE NoMonomorphismRestriction #-} -- helpful for certain debugging -- CPP definitions are now set using compiler options; see ./z and ./ile.--- #define ANNOTATED 0--- #define PARALLEL 0--- #define GHC_F 1+-- #define ANNOTATED 0+-- #define PARALLEL 0+-- #define GHC_F 1+-- #define DEBUG 0+-- #define CLEAN_EXTRANEOUS_GROUPINGS 0 -- Most helpful sources: -- - http://hpaste.org/steps/10722 -- use of everywhereM with State--- - #haskell (thanks dreixel, quintessence, eyebloom, ...)+-- - #haskell (thanks dreixel, ski, dolio, quintessence, ...) module Main(main) where import System.Environment(getArgs) import System.IO(writeFile,hFlush,stdout) - import Data.Data(Data)- import Data.Generics.Aliases(mkQ,mkT,mkM)- import Data.Generics.Schemes(everywhere,everywhereM,everything,gcount)---import Data.Generics -- this suffices to import all the above- #if PARALLEL import Control.Parallel.Strategies(rpar,parTraversable,runEval)---import Control.Parallel -- Not imported with Strategies, but- -- contains only par and pseq.---import Control.Concurrent----import Control.Exception----import System.IO.Unsafe----import Foreign #endif - import Control.Monad.State-- import System.Random(StdGen,mkStdGen,next)-- import Data.List(isPrefixOf)-+-- We must use a local, patched version of the haskell-src-exts package,+-- which is renamed "HSE" to avoid possible confusion. #if ANNOTATED import HSE.Annotated- import HSE.SrcLoc+--import Language.Haskell.Exts.Annotated #else import HSE+--import Language.Haskell.Exts #endif - import HSE.Extension- import FilesAndParsing------------------------------------------------------------------------------------#if ANNOTATED- fs_module :: Module SrcSpanInfo -> Module SrcSpanInfo-#else- fs_module :: Module -> Module-#endif- fs_module m0 = m4- where- m1 = everywhere (mkT step) m0- m2 = everywhere (mkT step2) m1- m3 = fs_guarded_rhss m2- m4 = fs_error_if_any_remain m3-#if ANNOTATED- step :: Rhs SrcSpanInfo -> Rhs SrcSpanInfo -- seems nec.-#else--- step :: Rhs -> Rhs -- unnec.-#endif-#if ANNOTATED- step (UnGuardedRhs srcSpanInfo e) = UnGuardedRhs srcSpanInfo e'-#else- step (UnGuardedRhs e) = UnGuardedRhs e'-#endif- where e' = fs_rhs_exp fresh e- step x = x-#if ANNOTATED- step2 :: Rhs SrcSpanInfo -> Rhs SrcSpanInfo -- seems nec.-#else--- step2 :: Rhs -> Rhs -- unnec.-#endif-#if ANNOTATED- step2 x@(UnGuardedRhs srcSpanInfo e)- | still_fsss = UnGuardedRhs srcSpanInfo e''-#else- step2 x@(UnGuardedRhs e)- | still_fsss = UnGuardedRhs e''-#endif- | otherwise = x- where- still_fsss = 0 < ( ( gcount (False `mkQ` p) x ) :: Int )-#if ANNOTATED- p :: Exp SrcSpanInfo -> Bool- p x@(FreeSectSlot _) = True-#else--- p :: Exp -> Bool- p x@FreeSectSlot = True-#endif- p _ = False- e'' = fs_rhs_exp fresh e'-#if ANNOTATED- e' = Paren srcSpanInfo e-#else- e' = Paren e-#endif- step2 x = x- fresh = fs_fresh_name m0--#if ANNOTATED- fs_guarded_rhss :: Module SrcSpanInfo -> Module SrcSpanInfo-#else- fs_guarded_rhss :: Module -> Module-#endif- fs_guarded_rhss m = m''- where- m' = everywhere (mkT step) m- m'' = everywhere (mkT step2) m'-#if ANNOTATED- step :: GuardedRhs SrcSpanInfo -> GuardedRhs SrcSpanInfo -- seems nec.-#else--- step :: GuardedRhs -> GuardedRhs -- unnec.-#endif-#if ANNOTATED- step (GuardedRhs srcSpanInfo slst e) = GuardedRhs srcSpanInfo slst e'-#else- step (GuardedRhs srcLoc slst e) = GuardedRhs srcLoc slst e'-#endif- where e' = fs_rhs_exp fresh e- step x = x-#if ANNOTATED- step2 :: GuardedRhs SrcSpanInfo -> GuardedRhs SrcSpanInfo -- seems nec.-#else--- step2 :: GuardedRhs -> GuardedRhs -- unnec.-#endif-#if ANNOTATED- step2 x@(GuardedRhs srcSpanInfo slst e)- | still_fsss = GuardedRhs srcSpanInfo slst e''-#else- step2 x@(GuardedRhs srcLoc slst e)- | still_fsss = GuardedRhs srcLoc slst e''-#endif- | otherwise = x- where- still_fsss = 0 < ( ( gcount (False `mkQ` p) x ) :: Int )-#if ANNOTATED- p :: Exp SrcSpanInfo -> Bool- p x@(FreeSectSlot _) = True-#else--- p :: Exp -> Bool- p x@FreeSectSlot = True-#endif- p _ = False- e'' = fs_rhs_exp fresh e'-#if ANNOTATED- e' = Paren srcSpanInfo e-#else- e' = Paren e-#endif- step2 x = x- fresh = fs_fresh_name m--#if ANNOTATED- fs_error_if_any_remain :: Module SrcSpanInfo -> Module SrcSpanInfo-#else- fs_error_if_any_remain :: Module -> Module-#endif- fs_error_if_any_remain m = m'- where- m' | still_fsss = error "Free sections can only occur in RHS Exp contexts."- | otherwise = m- still_fsss = 0 < ( ( gcount (False `mkQ` p) m ) :: Int )-#if ANNOTATED- p :: Exp SrcSpanInfo -> Bool- p x@(FreeSectSlot _) = True- p x@(FSContext _ _) = True-#else--- p :: Exp -> Bool- p x@FreeSectSlot = True- p x@(FSContext _) = True-#endif- p _ = False------------------------------------------------------------------------------------ -- v.0.0.5:- fs_rhs_exp :: Data a => String -> a -> a---fs_rhs_exp fresh rhs = rhs'- fs_rhs_exp fresh rhs = rhs''- where- rhs' = everywhere (mkT step) rhs- rhs'' | num_fss_remaining > 0 = everywhere (mkT step2) rhs'- | otherwise = rhs'-#if ANNOTATED- step x@(FSContext srcSpanInfo e) = fs_lambda ps' x'-#else- step x@(FSContext e) = fs_lambda ps' x'-#endif- where (x',(ps,_)) = fs_name_slots fresh x- ps' = reverse ps- step x = x- num_fss_remaining = ( gcount (False `mkQ` p) rhs' ) :: Int--- num_fss_remaining = ( error $ show $ ( gcount (False `mkQ` p) rhs' ) :: Int ) :: Int-#if ANNOTATED- p :: Exp SrcSpanInfo -> Bool- p x@(FreeSectSlot _) = True-#else--- p :: Exp -> Bool- p x@FreeSectSlot = True-#endif- p _ = False- -- Default context inference works as follows:- -- The (semilattice) join of all unbracketed __'s in a RHS is found.- -- Then, the innermost enclosing Paren or infix $ determines the context,- -- or -- if neither exists -- the whole RHS is taken as context.- --- -- Would prefer to use everywhereBut or something, to stop- -- searching farther, but ... would need an "everywhereButM" I think,- -- since need to pass on the info that an amenable Paren- -- has already been found.-#if ANNOTATED- step2 :: Exp SrcSpanInfo -> Exp SrcSpanInfo-#else--- step2 :: Exp -> Exp-#endif-#if ANNOTATED- -- | Paren l (Exp l)- step2 x@(Paren srcSpanInfo e)- | num_fss_remaining == gcount (False `mkQ` p) e- = x'_- | otherwise- = x- where- x_ = FSContext srcSpanInfo e-#else- step2 x@(Paren e)- | num_fss_remaining == gcount (False `mkQ` p) e- = x'_- | otherwise- = x- where- x_ = FSContext e-#endif- -- (We safely discarded the Paren from the AST since FSContext will- -- give Paren grouping behaviour in addition to freesect contexting.)- (x',(ps,_)) = fs_name_slots fresh x_- ps' = reverse ps- x'_ = fs_lambda ps' x'-#if ANNOTATED- -- | InfixApp l (Exp l) (QOp l) (Exp l)- step2 x@(InfixApp srcSpanInfo e1 qop e2)- | not good_op- = x- | num_fss_x < num_fss_remaining- = x- | num_fss_e2 == 0- = InfixApp srcSpanInfo e1'_ qop e2- | num_fss_e1 == 0- = InfixApp srcSpanInfo e1 qop e2'_- | otherwise- = x'_- where- e1_ = FSContext srcSpanInfo e1- e2_ = FSContext srcSpanInfo e2- x_ = FSContext srcSpanInfo x- -- May want to broaden this category? remember, it's a trade off,- -- if you use an op for a freesect context delimiter, it can't- -- be used inside a freesect with defaulting context.- -- To see why $ was chosen, check out the S23.hs test file.- good_op = case qop of- (QVarOp _ (UnQual _ (Symbol _ "$"))) -> True- _ -> False-#else- step2 x@(InfixApp e1 qop e2)- | not good_op- = x- | num_fss_x < num_fss_remaining- = x- | num_fss_e2 == 0- = InfixApp e1'_ qop e2- | num_fss_e1 == 0- = InfixApp e1 qop e2'_- | otherwise- = x'_- where- e1_ = FSContext e1- e2_ = FSContext e2- x_ = FSContext x- good_op = case qop of- (QVarOp (UnQual (Symbol "$"))) -> True- _ -> False-#endif- (e1',(ps1,_)) = fs_name_slots fresh e1_- ps1' = reverse ps1- (e2',(ps2,_)) = fs_name_slots fresh e2_- ps2' = reverse ps2- (x',(ps,_)) = fs_name_slots fresh x_- ps' = reverse ps- e1'_ = fs_lambda ps1' e1'- e2'_ = fs_lambda ps2' e2'- x'_ = fs_lambda ps' x'- num_fss_e1 = ( gcount (False `mkQ` p) e1 ) :: Int- num_fss_e2 = ( gcount (False `mkQ` p) e2 ) :: Int- num_fss_x = gcount (False `mkQ` p) x- step2 x = x--#if ANNOTATED- fs_lambda :: [String] -> Exp SrcSpanInfo -> Exp SrcSpanInfo -- seems nec.-#else---fs_lambda :: [String] -> Exp -> Exp -- unnec.-#endif- fs_lambda ps_lambda e_lambda-#if ANNOTATED- | null ps_lambda = error $ "Error: Free section contains no wildcards.\n"- ++ showSLorSSI ssi-#else- | null ps_lambda = error $ "Error: Free section contains no wildcards.\n"- ++ "(Source location not available, try -annotated.)\n"-#endif- | otherwise = lambda- where-#if ANNOTATED- lambda = Lambda ssi ps_lambda' e_lambda''- ps_lambda' = map (\x->(PVar ssi (Ident ssi x))) ps_lambda- e_lambda'@(FSContext ssi e) = e_lambda- e_lambda'' = e-#else- lambda = Lambda srcloc ps_lambda' e_lambda''- ps_lambda' = map (\x->(PVar (Ident x))) ps_lambda- e_lambda'@(FSContext e) = e_lambda- e_lambda'' = e- srcloc = SrcLoc "" 0 0-#endif-+ import Util #if ANNOTATED- showSLorSSI :: SrcSpanInfo -> String- showSLorSSI (SrcSpanInfo si _)- = fileName si ++ ": line=" ++ show (startLine si)- ++ " col=" ++ show (startColumn si)+ import FreeSectAnnotated #else- showSLorSSI :: SrcLoc -> String- showSLorSSI sl@(SrcLoc n l c)- = n ++ ": line=" ++ show l ++ " col=" ++ show c+ import FreeSect #endif -------------------------------------------------------------------------------- - -- Perhaps ironically, I don't like using partially-point-free function- -- declarations like this, but I couldn't figure out what to do with- -- the second parameter if I made it explicit!- -- We need to construct the fresh names in this recursion anyway, so- -- may as well collect them rather than recompute them in the caller,- -- although we could because they are canonically constructable from- -- fresh and n, the Int part of the state.- fs_name_slots :: Data a => String -> a -> (a,([String],Int))- fs_name_slots fresh- = flip runState ([],0) . everywhereM (mkM step)- where-#if ANNOTATED- step :: MonadState ([String],Int) m => Exp SrcSpanInfo -> m (Exp SrcSpanInfo) -- seems nec.-#else--- step :: MonadState ([String],Int) m => Exp -> m Exp -- unnec.-#endif-#if ANNOTATED- step (FreeSectSlot srcSpanInfo)-#else- step FreeSectSlot-#endif- = do (ss,n) <- get- let s = fresh ++ show n--- let s = "freeSect_" ++ show n- put ((s:ss),(1+n))-#if ANNOTATED- return $ ( Var srcSpanInfo ( UnQual srcSpanInfo ( Ident srcSpanInfo s ) ) )-#else- return $ Var $ UnQual $ Ident $ s-#endif- step x = return x-- fs_all_identifiers :: Data a => a -> [String]- fs_all_identifiers = everything (++) ([] `mkQ` f)- where-#if ANNOTATED- f :: (Name SrcSpanInfo) -> [String] -- seems nec.-#else--- f :: Name -> [String] -- unnec.-#endif-#if ANNOTATED- f (Ident _ x) = [x]-#else- f (Ident x) = [x]-#endif- f _ = []-- -- The names which FreeSect inserts will never conflict with each other.- -- We only need to assure they don't conflict with any existing names.- -- Actually, we need to make sure the name created here is not a prefix- -- of any existing name, because we add _XY to freesect slot names.-#if ANNOTATED- fs_fresh_name :: Module SrcSpanInfo -> String-#else- fs_fresh_name :: Module -> String-#endif- fs_fresh_name m = f g- where- ss = fs_all_identifiers m- g = mkStdGen 123 -- arbitrary seed- -- The following was much simpler when accept whole of r- -- as the random part of the name -- however, that made for- -- ugly long names, and so we try for the shortest possible- -- first. (If you never inspect the intermediate code, you- -- wouldn't care if the var names were ugly...)- f :: StdGen -> String- f g | b = s- | otherwise = f g' -- unlikely- where (r,g') = next g- (b,s) = f' rs (0,length rs)- rs = show r- f' :: String -> (Int,Int) -> (Bool,String)- f' s (n,ntop) | n > ntop = (False,"")- | not fail = (True,s'')- | otherwise = f' s (1+n,ntop)- where s' = take n s- s'' = s' ++ "_"--- s'' = "fs" ++ s' ++ "_"- fail = or $ map (isPrefixOf s'') ss------------------------------------------------------------------------------------#if ANNOTATED- stripFSPragma :: Module SrcSpanInfo -> Module SrcSpanInfo-#else- stripFSPragma :: Module -> Module-#endif-#if ANNOTATED- stripFSPragma (Module x1 x2 prags x4 x5)- = Module x1 x2 prags' x4 x5-#else- stripFSPragma (Module x1 x2 prags x4 x5 x6 x7)- = Module x1 x2 prags' x4 x5 x6 x7-#endif- where prags' = map f prags- f (LanguagePragma sl_or_ssi ns)- = LanguagePragma sl_or_ssi $ filter p ns- f x = x-#if ANNOTATED- p n@(Ident sl_or_ssi "FreeSections") = False-#else- p n@(Ident "FreeSections") = False-#endif- p _ = True--#if ANNOTATED- stripEmptyPragmaList :: Module SrcSpanInfo -> Module SrcSpanInfo-#else- stripEmptyPragmaList :: Module -> Module-#endif-#if ANNOTATED- stripEmptyPragmaList (Module x1 x2 prags x4 x5)- = Module x1 x2 prags' x4 x5-#else- stripEmptyPragmaList (Module x1 x2 prags x4 x5 x6 x7)- = Module x1 x2 prags' x4 x5 x6 x7-#endif- where prags' = filter p prags- p (LanguagePragma ssi []) = False- p _ = True--#if ANNOTATED- fixModuleName :: String -> Module SrcSpanInfo -> Module SrcSpanInfo-#else- fixModuleName :: String -> Module -> Module-#endif-#if ANNOTATED- fixModuleName name (Module x1 x2 x3 x4 x5)- = Module x1 name' x3 x4 x5-#else- fixModuleName name (Module x1 x2 x3 x4 x5 x6 x7)- = Module x1 name' x3 x4 x5 x6 x7-#endif- where-#if ANNOTATED- (Just (ModuleHead ssi _ mwt mesl)) = x2- name' = Just (ModuleHead ssi (ModuleName ssi name) mwt mesl)-#else- (ModuleName _) = x2- name' = ModuleName name-#endif- p (LanguagePragma ssi []) = False- p _ = True------------------------------------------------------------------------------------ main:: IO ()+ main :: IO () main- = do (- outfile :- lexsrc_pathnames- ) <- getArgs+ = do (outfile:lexsrc_pathnames) <- getArgs lexsrc_serials_ <- mapM readSourcesFromFileOrDir lexsrc_pathnames let (pnames,lexsrc_serials) = unzip $ concat $ reverse lexsrc_serials_ #if ANNOTATED #if PARALLEL- parsedsrc_maybes = (runEval $ parTraversable rpar $ doParsing pnames lexsrc_serials) :: [ParseResult (Module SrcSpanInfo)]+ parsedsrc_maybes+ = (runEval $ parTraversable rpar+ $ doParsing pnames lexsrc_serials)+ :: [ParseResult (Module SrcSpanInfo)] #else- parsedsrc_maybes = (doParsing pnames lexsrc_serials) :: [ParseResult (Module SrcSpanInfo)]+ parsedsrc_maybes+ = (doParsing pnames lexsrc_serials)+ :: [ParseResult (Module SrcSpanInfo)] #endif #else- parsedsrc_maybes = (doParsing pnames lexsrc_serials) :: [ParseResult Module]+ parsedsrc_maybes+ = (doParsing pnames lexsrc_serials) :: [ParseResult Module] #endif let -- parsed_srcs = error $ ( ( concatMap prettyPrint $ ( ( testParses parsedsrc_maybes ) :: [Module] ) ) :: String )@@ -529,12 +79,16 @@ #else parsed_srcs = ( testParses parsedsrc_maybes ) :: [Module] #endif-{--+#if 0 let- test = ( error $ show $ map fs_FSS_lineal_chains parsed_srcs ) :: String+ test = ( error $ show $ map fs_FSW_lineal_chains parsed_srcs ) :: String print test---}+#endif let+#if 0+ -- for debugging, we sometimes like to bypass the transformation+ transformed_srcs = parsed_srcs+#else #if ANNOTATED #if PARALLEL transformed_srcs = ( runEval $ parTraversable rpar $ @@ -554,7 +108,7 @@ ) :: [Module] #endif #endif--- transformed_srcs = parsed_srcs+#endif let transformed_srcs' = map stripFSPragma transformed_srcs@@ -566,30 +120,37 @@ #if GHC_F debug parsed_srcs transformed_srcs''- writeFile outfile $ -- with ghc -F- concatMap prettyPrint transformed_srcs''+ writeFile outfile $ concatMap prettyPrint transformed_srcs'' #else debug parsed_srcs transformed_srcs'''- writeFile (outfile++".hs") $- concatMap prettyPrint transformed_srcs'''+ writeFile (outfile++".hs") $ concatMap prettyPrint transformed_srcs''' #endif hFlush stdout +--------------------------------------------------------------------------------++#if 0+-- actually unnecessary (and this comment can't go on the #if 0 line...) #if ANNOTATED debug :: [Module SrcSpanInfo] -> [Module SrcSpanInfo] -> IO () #else debug :: [Module] -> [Module] -> IO () #endif+#endif debug ms ms' = do+#if DEBUG #if 0+ -- one-liner AST tree dump (before-and-after) putStrLn $ show ms putStrLn $ show ms' #endif #if 1+ -- pretty-printed lexical sourcecode (before-and-after) putStrLn $ concatMap prettyPrint ms putStrLn $ concatMap prettyPrint ms'+#endif #endif return ()
Makefile view
@@ -1,7 +1,7 @@ # >>BINPATHNAME<< ./dist/build/freesect/freesect: \-./Main.hs ./FilesAndParsing.hs ./HSE.hs ./HSE/Annotated.hs ./HSE/Annotated/Build.hs ./HSE/Annotated/ExactPrint.hs ./HSE/Annotated/Fixity.hs ./HSE/Annotated/Simplify.hs ./HSE/Annotated/Syntax.hs ./HSE/Build.hs ./HSE/Comments.hs ./HSE/ExtScheme.hs ./HSE/Extension.hs ./HSE/Fixity.hs ./HSE/Lexer.hs ./HSE/ParseMonad.hs ./HSE/ParseSyntax.hs ./HSE/ParseUtils.hs ./HSE/Parser.hs ./HSE/Pretty.hs ./HSE/SrcLoc.hs ./HSE/Syntax.hs ./HSE/InternalParser.hs+./Main.hs ./FreeSect.hs ./FreeSectAnnotated.hs ./FilesAndParsing.hs ./Util.hs ./HSE.hs ./HSE/Annotated.hs ./HSE/Annotated/Build.hs ./HSE/Annotated/ExactPrint.hs ./HSE/Annotated/Fixity.hs ./HSE/Annotated/Simplify.hs ./HSE/Annotated/Syntax.hs ./HSE/Build.hs ./HSE/Comments.hs ./HSE/ExtScheme.hs ./HSE/Extension.hs ./HSE/Fixity.hs ./HSE/Lexer.hs ./HSE/ParseMonad.hs ./HSE/ParseSyntax.hs ./HSE/ParseUtils.hs ./HSE/Parser.hs ./HSE/Pretty.hs ./HSE/SrcLoc.hs ./HSE/Syntax.hs ./HSE/InternalParser.hs csh ile # Needed because of use of CPP definitions across multiple source files.@@ -9,8 +9,14 @@ # require recompilation of affected modules. ./Main.hs: ./z touch Main.hs+./FreeSect.hs: ./z+ touch FreeSect.hs+./FreeSectAnnotated.hs: ./z+ touch FreeSectAnnotated.hs ./FilesAndParsing.hs: ./z touch FilesAndParsing.hs+./Util.hs: ./z+ touch Util.hs ./HSE/InternalParser.hs: ./HSE/InternalParser.ly happy -agc -o HSE/InternalParser.hs HSE/InternalParser.ly
S24.hs view
@@ -4,6 +4,7 @@ -- Might as well test interaction with the pre-existing -- tuple section generalisation. (GHC knows about this one.) {-# LANGUAGE TupleSections #-}+ {- # LANGUAGE ParallelListComp #-} -- broken; see comment below module S24 where @@ -58,13 +59,15 @@ -- EnumFromThenTo Exp Exp Exp -- bounded arithmetic sequence with stride v= _[ [__,__..__] ]_ 3 5 8 -- ListComp Exp [QualStmt] -- ordinary list comprehension- v= _[ [f __ x|x<-[1..3]] ]_ 2+ v= _[ [f __ x | x<-[1..3]] ]_ 2 {- still not working- v= _[ [f 2 x|x<- __ ] ]_ [1..3]- v= _[ [f __ x|x<- __ ] ]_ 2 [1..3]+ v= _[ [f 2 x | x<- __ ] ]_ [1..3]+ v= _[ [f __ x | x<- __ ] ]_ 2 [1..3] -}+{- Doesn't work; HSE inserts a , before the 2nd | resulting in syntax error. -- ParComp Exp [[QualStmt]] -- parallel list comprehension---v= ??+ v= _[ [f __ x y | x<-[1..3] | y<-[4..6]] ]_ 2+-} -- ExpTypeSig SrcLoc Exp Type -- expression with explicit type signature --v= __ :: Int->Int $ 2 v= _[ __ :: Int->Int ]_ 2
S25.hs view
@@ -4,6 +4,7 @@ -- Might as well test interaction with the pre-existing -- tuple section generalisation. (GHC knows about this one.) {-# LANGUAGE TupleSections #-}+ {- # LANGUAGE ParallelListComp #-} -- broken; see comment below module S25 where @@ -44,25 +45,29 @@ -- RightSection QOp Exp -- right section @(@/qop/ /exp/@)@ v= (+ __) -- RecUpdate Exp [FieldUpdate] -- record update expression+ v= (__ { f3 = 2 }) Ctor v= __ { f3 = 2 } $ Ctor+ v= (Ctor { f3 = __ }) 2 v= Ctor { f3 = __ } $ 2 -- EnumFrom Exp -- unbounded arithmetic sequence v= [__..]- v= [__..] $ 3+ v= [__..] 3 -- EnumFromTo Exp Exp -- bounded arithmetic sequence- v= [__..__] $ 3 5+ v= [__..__] 3 5 -- EnumFromThen Exp Exp -- unbounded arithmetic sequence with stride- v= [__,__..] $ 3 5+ v= [__,__..] 3 5 -- EnumFromThenTo Exp Exp Exp -- bounded arithmetic sequence with stride- v= [__,__..__] $ 3 5 8+ v= [__,__..__] 3 5 8 -- ListComp Exp [QualStmt] -- ordinary list comprehension- v= [f __ x|x<-[1..3]] $ 2+ v= [f __ x|x<-[1..3]] 2 {- still not working- v= [f 2 x|x<- __ ] $ [1..3]- v= [f __ x|x<- __ ] $ 2 [1..3]+ v= [f 2 x|x<- __ ] [1..3]+ v= [f __ x|x<- __ ] 2 [1..3] -}+{- Doesn't work; HSE inserts a , before the 2nd | resulting in syntax error. -- ParComp Exp [[QualStmt]] -- parallel list comprehension---v= ??+ v= [f __ x y | x<-[1..3] | y<-[4..6]] 2+-} -- ExpTypeSig SrcLoc Exp Type -- expression with explicit type signature --v= __ :: Int->Int $ 2 v= (__ :: Int->Int) 2
S27.hs view
@@ -2,9 +2,43 @@ module S27 where - v= f __ y+ -- <ski>'s example of a pathology of the present context inferencing policy.+ -- We'd expect these two expressions to have the same semantics, but sadly+ -- they do not. Although it's true that people don't write (f x) y often+ -- because left-associativity of application makes the parentheses+ -- superfluous, nevertheless...+ --+ -- However, question: Can we prove that both interpretations can not+ -- both be simultaneously well-typed, under all possible circumstances?+ -- If so, then the type error is a much better eventuality than the+ -- compiler silently accepting code that wasn't intended.+ --+ -- As for attempting to recognise these particular cases and adjust+ -- the contextualisation algorithm to accomodate them, nah, that+ -- just feels wrong. - v= a $ b __ c $ d+ v= f __ y -- = _[ f __ y ]_ = \ a -> f a y+ v= (f __) y -- = _[ f __ ]_ y = ( \ a -> f a ) y++--------------------------++ v= a $ b __ c $ d -- this works: (= a $ (\ _0 -> b _0 c) $ d)++--------------------------++-- Testing that freesect translation "stops" in the subexpression,+-- if all the __'s are in but one of the subexpressions.+ v= [ ((__+2) 3) .. ]+ v= [ 1, ((__+2) 3) .. ]+{-+ -- Translation is correct but the expressions are erroneous,+ -- since there's no way to apply the section, which is inside+ -- a list enumeration, to an argument which must be outside.+ v= [ (__+2) .. ]+ v= [ 1,(__+2) .. ]+-}++-------------------------- --v= [x|x<- __ ] [1..3] -- XXX still a problem, but must be commented-out -- -- because otherwise freesect runtime error.
Setup.hs view
@@ -1,5 +1,5 @@ import Distribution.Simple import System(getArgs) main = do (a:_) <- getArgs- putStr $ if a == "build" then "\n ** Please see 000-readme in the distro tarball for building and usage. **\n\n" else ""+ putStr $ if a == "build" then "\n ** Please see 000-readme in the distro tarball for usage. **\n\n" else "" defaultMain
+ Util.hs view
@@ -0,0 +1,129 @@++-- Package: freesect-0.8+-- Description: Extend Haskell to support free sections+-- Example: zipWith (f __ b __ d) as cs+-- Author: Andrew Seniuk <rasfar@gmail.com>+-- Date: March 11, 2012+-- License: BSD3 (./LICENSE)+-- Executable: freesect+-- Usage: See accompanying files 000-readme and z++{-# LANGUAGE CPP #-}++-- CPP definitions are set using compiler options; see ./z and ./ile.++ module Util where++ import Data.Generics.Aliases(mkQ)+ import Data.Generics.Schemes(everything)+--import Data.Generics -- this suffices to import both the above++ import System.Random(StdGen,mkStdGen,next)++ import Data.List(isPrefixOf)++#if ANNOTATED+ import HSE.Annotated+#else+ import HSE+#endif++--------------------------------------------------------------------------------++#if ANNOTATED+ stripFSPragma (Module x1 x2 prags x4 x5)+ = Module x1 x2 prags' x4 x5+#else+ stripFSPragma (Module x1 x2 prags x4 x5 x6 x7)+ = Module x1 x2 prags' x4 x5 x6 x7+#endif+ where prags' = map f prags+ f (LanguagePragma sl_or_ssi ns)+ = LanguagePragma sl_or_ssi $ filter p ns+ f x = x+#if ANNOTATED+ p n@(Ident sl_or_ssi "FreeSections") = False+#else+ p n@(Ident "FreeSections") = False+#endif+ p _ = True++#if ANNOTATED+ stripEmptyPragmaList (Module x1 x2 prags x4 x5)+ = Module x1 x2 prags' x4 x5+#else+ stripEmptyPragmaList (Module x1 x2 prags x4 x5 x6 x7)+ = Module x1 x2 prags' x4 x5 x6 x7+#endif+ where prags' = filter p prags+ p (LanguagePragma ssi []) = False+ p _ = True++#if ANNOTATED+ fixModuleName name (Module x1 x2 x3 x4 x5)+ = Module x1 name' x3 x4 x5+#else+ fixModuleName name (Module x1 x2 x3 x4 x5 x6 x7)+ = Module x1 name' x3 x4 x5 x6 x7+#endif+ where+#if ANNOTATED+ (Just (ModuleHead ssi _ mwt mesl)) = x2+ name' = Just (ModuleHead ssi (ModuleName ssi name) mwt mesl)+#else+ (ModuleName _) = x2+ name' = ModuleName name+#endif+ p (LanguagePragma ssi []) = False+ p _ = True++--------------------------------------------------------------------------------++ -- The names which FreeSect inserts will never conflict with each other.+ -- We only need to assure they don't conflict with any existing names.+ -- Actually, we need to make sure the name created here is not a prefix+ -- of any existing name, because we add _XY to freesect slot names.+#if ANNOTATED+ fs_fresh_name :: Module SrcSpanInfo -> String -- nec. (since refactoring?)+#else+ fs_fresh_name :: Module -> String -- nec. (since refactoring?)+#endif+ fs_fresh_name m = f g+ where+ ss = fs_all_identifiers m+ g = mkStdGen 123 -- arbitrary seed+ -- The following was much simpler when accept whole of r+ -- as the random part of the name -- however, that made for+ -- ugly long names, and so we try for the shortest possible+ -- first. (If you never inspect the intermediate code, you+ -- wouldn't care if the var names were ugly...)+ f :: StdGen -> String+ f g | b = s+ | otherwise = f g' -- unlikely+ where (r,g') = next g+ (b,s) = f' rs (0,length rs)+ rs = show r+ f' :: String -> (Int,Int) -> (Bool,String)+ f' s (n,ntop) | n > ntop = (False,"")+ | not fail = (True,s'')+ | otherwise = f' s (1+n,ntop)+ where s' = take n s+ s'' = s' ++ "_"+-- s'' = "fs" ++ s' ++ "_"+ fail = or $ map (isPrefixOf s'') ss++--fs_all_identifiers :: Data a => a -> [String]+ fs_all_identifiers = everything (++) ([] `mkQ` f)+ where+#if ANNOTATED+ f :: Name SrcSpanInfo -> [String] -- seems nec.+#else+-- f :: Name -> [String] -- unnec.+#endif+#if ANNOTATED+ f (Ident _ x) = [x]+#else+ f (Ident x) = [x]+#endif+ f _ = []+
cln view
@@ -4,7 +4,7 @@ echo "Check script first, it uses rm..." exit 1 -## Temp file created by freesect (non GHC -F mode):+## Temp files created by freesect (non ghc -F mode): rm -f Z_[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f]* >&! /dev/null ## Temp dirs created by GHC:@@ -22,7 +22,10 @@ ## FreeSect generated object and interface files: #rm -f Main.{o,hi} >&! /dev/null+#rm -f FreeSect.{o,hi} >&! /dev/null+#rm -f FreeSectAnnotated.{o,hi} >&! /dev/null #rm -f FilesAndParsing.{o,hi} >&! /dev/null+#rm -f Util.{o,hi} >&! /dev/null ## Patched HSE generated object and interface files: #rm -f HSE.{o,hi} >&! /dev/null
freesect.cabal view
@@ -1,9 +1,9 @@ Name: freesect-Version: 0.7+Version: 0.8 Synopsis: A Haskell syntax extension for generalised sections Description:- This package provides a preprocessor executable, \'freesect\', - which implements a generalisation of sections (\'free sections\')+ This package provides a preprocessor executable, \'freesect\', which+ implements a broad generalisation of sections (dubbed \'free sections\') for partial application and higher-order style. Some examples of free sections can be found in the included test suite; refer to the homepage for more info.@@ -12,19 +12,19 @@ License-file: LICENSE Author: Andrew Seniuk Maintainer: Andrew Seniuk <rasfar@gmail.com>-Stability: Provisional+Stability: Experimental Category: Language-Build-type: Custom-Cabal-version: >= 1.2.3+Build-type: Simple+Cabal-version: >= 1.2 Extra-source-files: -- You might not make use of these ones: 000-readme, Makefile, cln, freesect.sh, ile, z, zpack, -- These are example modules containing free sections for testing: S14.hs, S15.hs, S23.hs, S24.hs, S25.hs, S26.hs, S27.hs, -- Snapshot of documentation; visit the homepage for up-to-date versions:- Doc/index.html, Doc/irc.html,+ Doc/index.html, Doc/irc.html, Doc/primitives.html, -- The rest are critical for building freesect:- FilesAndParsing.hs,+ FreeSect.hs, FreeSectAnnotated.hs, FilesAndParsing.hs, Util.hs, -- Since HSE is not yet patched to include -XFreeSections, we need -- to build a patched version locally, hence these dependencies: HSE/InternalParser.ly,@@ -61,7 +61,8 @@ -- syn >= 0.1 should suffice judging by the API but this is not tested... syb >= 0.1 , -- Recommended but not actually needed if the CPP #define PARALLEL is 0.--- >= 3.0 for parTraversable (could use parList, and get >= 2.0)+-- The parallel package has changed several times in a compatability-breaking+-- manner. You need >= 3.0 for runEvaal and parTraversable. parallel >= 3.0 , -- haskell-src-exts >= 1.11.1 , -- Since HSE is not yet patched to include -XFreeSections, we need@@ -69,10 +70,13 @@ cpphs >= 1.3 , pretty >= 1.0 , array >= 0.1- extensions: DeriveDataTypeable, FlexibleContexts, CPP+ extensions: FlexibleContexts, CPP+-- It seems that it is not necessary to declare -XDeriveDataTypeable (or+-- to use the corresponding LANGUAGE pragma)? True even for GHC 6.12.4.+--extensions: DeriveDataTypeable, FlexibleContexts, CPP+-- (The happy output is provided in the distro.) Build-tools:---Build-tools: happy- other-modules:- ghc-options: -O0 -rtsopts -threaded- cpp-options: -DANNOTATED=0 -DPARALLEL=0 -DGHC_F=1+--Build-Tools: happy >= 1.17+ ghc-options: -O0 -rtsopts -threaded -fno-warn-overlapping-patterns+ cpp-options: -DANNOTATED=0 -DPARALLEL=0 -DGHC_F=1 -DDEBUG=1 -DCLEAN_EXTRANEOUS_GROUPINGS=0
freesect.sh view
@@ -6,6 +6,7 @@ # >>BINPATHNAME<< #binpathname=/media/ramdisk/freesect binpathname=./dist/build/freesect/freesect+#binpathname=~/.cabal/bin/freesect $binpathname \ $rtsopts \
ile view
@@ -4,9 +4,13 @@ if ( ! $?FS_ANNOTATED ) setenv FS_ANNOTATED 0 if ( ! $?FS_PARALLEL ) setenv FS_PARALLEL 0 if ( ! $?FS_GHC_F ) setenv FS_GHC_F 0+ if ( ! $?FS_DEBUG ) setenv FS_DEBUG 0+ if ( ! $?FS_CLEAN_EXTRANEOUS_GROUPINGS ) setenv FS_CLEAN_EXTRANEOUS_GROUPINGS echo ANNOTATED=$FS_ANNOTATED echo PARALLEL=$FS_PARALLEL echo GHC_F=$FS_GHC_F+echo DEBUG=$FS_DEBUG+echo CLEAN_EXTRANEOUS_GROUPINGS=$FS_CLEAN_EXTRANEOUS_GROUPINGS mkdir -p dist/build/freesect/freesect-tmp >&! /dev/null @@ -15,8 +19,8 @@ set binpathname = ./dist/build/freesect/freesect ghc --make \- -idist/build/freesect/freesect-tmp \- -outputdir dist/build/freesect/freesect-tmp \+ -i./dist/build/freesect/freesect-tmp \+ -outputdir ./dist/build/freesect/freesect-tmp \ # Since 2010 or so, GHC requires this option to use +RTS ... -RTS: \ -rtsopts \ # For -prof, don't forget you need the +RTS -p -RTS when running \@@ -28,6 +32,8 @@ -optP "-DANNOTATED=$FS_ANNOTATED" \ -optP "-DPARALLEL=$FS_PARALLEL" \ -optP "-DGHC_F=$FS_GHC_F" \+ -optP "-DDEBUG=$FS_DEBUG" \+ -optP "-DCLEAN_EXTRANEOUS_GROUPINGS=$FS_CLEAN_EXTRANEOUS_GROUPINGS" \ -fno-warn-overlapping-patterns \ Main -o $binpathname \ ##!!
z view
@@ -6,12 +6,14 @@ setenv FS_ANNOTATED 0 setenv FS_PARALLEL 0 setenv FS_GHC_F 1+ setenv FS_DEBUG 1+ setenv FS_CLEAN_EXTRANEOUS_GROUPINGS 0 if ( ${#argv} == 0 ) then set test=S25 else if ( ${#argv} > 1 ) then foreach i ( $* )- source ./z $i+ source ./z $i:r end exit else@@ -68,11 +70,13 @@ | sed -e 's/)))))*/)..)/g' \ ##!! -echo-echo-echo "(Ignore errors about missing symbols; you can examine"-echo "freesect pre-processor output in the intermediate file.)"-echo+if ( $zstat ) then+ echo+ echo+ echo "(Ignore errors about names not in scope; you can examine"+ echo "freesect pre-processor output in the intermediate file.)"+ echo+endif if ( $zstat ) exit 1 @@ -128,11 +132,13 @@ set zstat=$? -echo-echo-echo "(Ignore errors about missing symbols; you can examine"-echo "freesect pre-processor output in the intermediate file.)"-echo+if ( $zstat ) then+ echo+ echo+ echo "(Ignore errors about names not in scope; you can examine"+ echo "freesect pre-processor output in the intermediate file.)"+ echo+endif if ( $zstat ) exit 1 # won't work for Main's exit status, after the pipe
zpack view
@@ -1,4 +1,4 @@-#+#!/bin/csh # Package with cabal, and attempt build in test dir ./TestBuild. @@ -34,6 +34,10 @@ .+1s/^#/ / wq 'EOF'+ed -s ./Doc/index.html >&! /dev/null <<'EOF'+,s/http:\/\/www\.fremissant\.net\/freesect\//.\//g+wq+'EOF' # 2) Attempt to run cabal sdist. @@ -74,6 +78,10 @@ /CLNSCRIPT/ .+1s/^ /#/ .+1s/^ /#/+wq+'EOF'+ed -s ./Doc/index.html >&! /dev/null <<'EOF'+,s/href=\".\//href=\"http:\/\/www.fremissant\.net\/freesect\//g wq 'EOF'