packages feed

fenfire (empty) → 0.1

raw patch · 71 files changed

+20214/−0 lines, 71 filesdep +HaXmldep +basedep +cairobuild-type:Customsetup-changedbinary-added

Dependencies added: HaXml, base, cairo, gtk, harp, mtl, template-haskell, unix

Files

+ Cache.hs view
@@ -0,0 +1,112 @@+module Cache where++import Utils++import Data.Bits+import Data.HashTable (HashTable)+import qualified Data.HashTable as HashTable+import Data.Int+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (isJust, fromJust)+import Data.Unique++import Control.Monad (when)++import System.IO.Unsafe+import System.Mem.StableName+++class Hashable a where+    hash :: a -> Int32+    +instance Hashable String where+    hash s = HashTable.hashString s+    +instance Hashable Int where+    hash i = HashTable.hashInt i+    +instance Hashable Unique where+    hash u = hash (hashUnique u)+    +instance Hashable (StableName a) where+    hash n = hash (hashStableName n)+    +instance (Hashable a, Hashable b) => Hashable (a,b) where+    hash (x,y) = hash x `xor` HashTable.hashInt (fromIntegral $ hash y)+    ++type LinkedList a = IORef (LinkedNode a)++data LinkedNode a = +    LinkedNode { lnPrev :: LinkedList a, lnValue :: IORef a, +                 lnNext :: LinkedList a }+  | End { lnPrev :: LinkedList a, lnNext :: LinkedList a }+  +isEnd (LinkedNode _ _ _) = False+isEnd (End        _   _) = True+    +newList :: IO (LinkedList a)+newList = mdo let end = End p n+              p <- newIORef end; n <- newIORef end; list <- newIORef end+              return list++newNode :: a -> IO (LinkedNode a)+newNode x = do let err = error "Cache: access to not-yet-linked node"+               p <- newIORef err; val <- newIORef x; n <- newIORef err+               return (LinkedNode p val n)+               +appendNode :: LinkedNode a -> LinkedList a -> IO ()+appendNode node list = do n <- readIORef list; p <- readIORef (lnPrev n)+                          writeIORef (lnNext p) node; writeIORef (lnPrev n) node+                          writeIORef (lnPrev node) p; writeIORef (lnNext node) n+                    +removeFirst :: LinkedList a -> IO a+removeFirst list = do l <- readIORef list; node <- readIORef (lnNext l)+                      removeNode node+                      readIORef (lnValue node)++removeNode :: LinkedNode a -> IO ()+removeNode node = do when (isEnd node) $ error "Cache: remove from empty list"+                     p <- readIORef (lnPrev node); n <- readIORef (lnNext node)+                     let err = error "Cache: access to unlinked node"+                     writeIORef (lnPrev node) err; writeIORef (lnNext node) err+                     writeIORef (lnNext p) n; writeIORef (lnPrev n) p+    +access :: LinkedList a -> LinkedNode a -> IO ()+access list node = do removeNode node; appendNode node list++add :: a -> LinkedList a -> IO (LinkedNode a)+add x list = do node <- newNode x; appendNode node list; return node+++byAddress :: a -> StableName a+byAddress = unsafePerformIO . makeStableName+++type Cache key value =+    (IORef Int, Int, HashTable key (value, LinkedNode key), LinkedList key)++newCache :: (Eq key, Hashable key) => Int -> Cache key value+newCache maxsize = unsafePerformIO $ do ht <- HashTable.new (==) hash+                                        lru <- newList; size <- newIORef 0+                                        return (size, maxsize, ht, lru)++cached :: (Eq k, Hashable k) => k -> Cache k v -> v -> v+cached key (sizeRef, maxsize, cache, lru) val = unsafePerformIO $ do+    mval' <- HashTable.lookup cache key+    if isJust mval' then do+        let (val', node) = fromJust mval'+        access lru node+        --putStrLn "Cache access"+        return val'+      else do+        size <- readIORef sizeRef+        --putStrLn ("Cache add, former size " ++ show size)+        if size < maxsize then writeIORef sizeRef (size+1)+                          else do dropped <- removeFirst lru+                                  HashTable.delete cache dropped+        node <- add key lru+        HashTable.insert cache key (val, node)+        return val
+ Cairo.fhs view
@@ -0,0 +1,193 @@+-- For (instance (Cairo cx r, Monoid m) => Monoid (cx m)):+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}+-- More, implied by the previous on GHC 6.6 but needed for earlier:+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+module Cairo where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Utils++import Control.Applicative+import Control.Monad++import Data.Monoid (Monoid(mappend, mempty))++import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)+import qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))+import qualified Graphics.Rendering.Cairo.Matrix as Matrix+import Graphics.UI.Gtk.Cairo++data Color = Color Double Double Double Double+type Size  = (Double, Double)+type Point = (Double, Double)+type Rect  = (Matrix, Size)++type Render a = C.Render a+newtype Path  = Path { renderPath :: Render () }    deriving Monoid++class (Applicative cx, Monoid r) => +      Cairo cx r | cx -> r, r -> cx where+    cxAsk    :: cx Rect+    cxLocal  :: cx Rect -> Endo (cx a)+    +    cxWrap   :: EndoM cx (Render ()) -> Endo r+    cxLocalR :: cx Rect -> Endo r++    cxRender :: cx (Render ()) -> r+    cxRender r = cxWrap (const r) mempty+    +instance Monoid (Render ()) where+    mempty = return ()+    mappend = (>>)++instance (Applicative m, Monoid o) => Monoid (m o) where+    mempty = pure mempty+    mappend = liftA2 mappend+        +instance Cairo ((->) Rect) (Rect -> Render ()) where+    cxAsk = id+    cxLocal f m r = m (f r)+    +    cxWrap f ren r = f (ren r) r+    cxLocalR f ren r = ren (f r)++newtype InContext a b = InContext { appContext :: a -> b } deriving Monoid++instance Cairo cx r => Cairo (Comp ((->) a) cx) (InContext a r) where+    cxAsk = Comp (const cxAsk)+    cxLocal (Comp f) (Comp m) = Comp $ \a -> cxLocal (f a) (m a)+    +    cxWrap f c = InContext $ \a -> cxWrap (\ren -> (fromComp $ f ren) a)+                                          (c `appContext` a)+    cxLocalR f c = InContext $ \a -> cxLocalR (fromComp f a) (c `appContext` a)++cxMatrix :: Cairo cx r => cx Matrix+cxMatrix = fmap fst cxAsk++cxSize :: Cairo cx r => cx Size+cxSize = fmap snd cxAsk+++[black, gray, lightGray, white] = [Color x x x 1 | x <- [0, 0.5, 0.9, 1]]+++fill :: Cairo cx r => cx Path -> r+fill p = cxRender $ forA2 p cxMatrix $ \p' m -> do+    renderPath p'; C.save; C.transform m; C.fill; C.restore++stroke :: Cairo cx r => cx Path -> r+stroke p = cxRender $ forA2 p cxMatrix $ \p' m -> do+    renderPath p'; C.save; C.transform m; C.stroke; C.restore++paint :: Cairo cx r => r+paint = cxRender $ pure C.paint++clip :: Cairo cx r => cx Path -> Endo r+clip p = cxWrap $ \ren -> ffor p $ \p' -> do+    C.save; renderPath p'; C.clip; ren; C.restore+    +    +withColor :: Cairo cx r => cx Color -> Endo r+withColor c = cxWrap $ \ren -> ffor c $ \(Color r g b a) -> do+    C.save; C.setSourceRGBA r g b a; ren; C.restore+    +withDash :: Cairo cx r => cx [Double] -> cx Double -> Endo r+withDash a b = cxWrap $ \ren -> #(C.save >> C.setDash !a !b >> ren >> C.restore)+    +transform :: Cairo cx r => cx (Endo Matrix) -> Endo r+transform f = cxLocalR #(!f Matrix.identity * !cxMatrix, !cxSize)++-- | Moves a renderable by x and y.+--+translate :: Cairo cx r => cx Double -> cx Double -> Endo r+translate x y = transform $ liftA2 Matrix.translate x y++-- | Moves a renderable to the specific point p.+--+translateTo :: Cairo cx r => cx Point -> Endo r+translateTo p = translate x y where+    (x,y) = funzip #(Matrix.transformPoint (Matrix.invert !cxMatrix) !p)++-- | Rotates a renderable by angle.+--+rotate :: Cairo cx r => cx Double -> Endo r+rotate angle = transform $ fmap Matrix.rotate angle++-- | Scales a renderable by sx and sy.+--+scale2 :: Cairo cx r => cx Double -> cx Double -> Endo r+scale2 sx sy = transform $ liftA2 Matrix.scale sx sy+    +-- | Scales a renderable by sc.+--+scale :: Cairo cx r => cx Double -> Endo r+scale sc = scale2 sc sc+++between :: Cairo cx r => cx Point -> cx Point -> Endo r+between p1 p2 = translate #(avg !x1 !x2) #(avg !y1 !y2)+              . rotate #(atan2 (!y2 - !y1) (!x2 - !x1)) +    where (x1,y1) = funzip p1; (x2,y2) = funzip p2+++point :: Cairo cx r => cx Double -> cx Double -> cx Point+point x y = #(Matrix.transformPoint !cxMatrix (!x,!y))++anchor :: Cairo cx r => cx Double -> cx Double -> cx Point+anchor x y = #(Matrix.transformPoint !cxMatrix (!x * !w, !y * !h))+    where (w,h) = funzip cxSize++center :: Cairo cx r => cx Point+center = anchor #0.5 #0.5++closePath :: Cairo cx r => cx Path+closePath = pure $ Path $ C.closePath++arc :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double -> cx Path+arc p a b c = #(Path $ do+    let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p+    C.save; C.transform !cxMatrix; C.arc x y !a !b !c; C.restore)++arcNegative :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double -> +               cx Path+arcNegative p a b c = #(Path $ do+    let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p+    C.save; C.transform !cxMatrix; C.arcNegative x y !a !b !c; C.restore)++circle :: Cairo cx r => cx Point -> cx Double -> cx Path+circle p r = arc p r #0 #(2*pi)++curveTo :: Cairo cx r => cx Point -> cx Point -> cx Point -> cx Path+curveTo p1 p2 p3 = forA3 p1 p2 p3 $ \(x1,y1) (x2,y2) (x3,y3) ->+                       Path $ C.curveTo x1 y1 x2 y2 x3 y3++moveTo :: Cairo cx r => cx Point -> cx Path+moveTo p = ffor p $ \(x,y) -> Path $ do C.moveTo x y++lineTo :: Cairo cx r => cx Point -> cx Path+lineTo p = ffor p $ \(x,y) -> Path $ do C.lineTo x y++line :: (Cairo cx r, Monoid (cx Path)) => cx Point -> cx Point -> cx Path+line p1 p2 = moveTo p1 & lineTo p2++extents :: (Cairo cx r, Monoid (cx Path)) => cx Path+extents = moveTo (anchor #0 #0) & lineTo (anchor #0 #1) & lineTo (anchor #1 #1)+        & lineTo (anchor #1 #0) & lineTo (anchor #0 #0)
+ DaisyData.txt view
@@ -0,0 +1,53 @@+[+  ("A", [+    ("D", 19, 22)+  , ("NE", 3, 10)+  , ("AI", 14, 19)+  , ("B", 21, 34)+  , ("E", 33, 38)+  , ("Ä", 18, 25)+  , ("G", 24, 26)+  , ("F", 0, 1)+  , ("I", 0, 2)+  , ("H", 4, 5)+  , ("K", 10, 16)+  , ("J", 2, 5)+  , ("M", 9, 18)+  , ("L", 27, 29)+  , ("O", 9, 13)+  , ("N", 26, 28)+  , ("II", 3, 15)+  , ("P", 8, 14)+  , ("S", 1, 2)+  , ("R", 7, 18)+  , ("U", 5, 18)+  , ("T", 23, 23)+  , ("Y", 8, 10)+  , ("UI", 9, 17)+  , ("AU", 13, 23)+  ])+, ("B", [+    ("V", 4, 8)+  , ("D", 4, 25)+  , ("A", 18, 19)+  , ("E", 9, 26)+  , ("Ä", 5, 9)+  , ("G", 12, 20)+  , ("F", 7, 11)+  , ("I", 1, 15)+  , ("H", 33, 36)+  , ("K", 7, 21)+  , ("J", 19, 22)+  , ("M", 14, 37)+  , ("L", 27, 36)+  , ("O", 5, 8)+  , ("N", 19, 23)+  , ("P", 4, 5)+  , ("S", 0, 2)+  , ("R", 5, 6)+  , ("U", 14, 35)+  , ("T", 4, 23)+  , ("Ö", 22, 27)+  , ("Y", 32, 39)+  ])+]
+ Darcs2RDF.fhs view
@@ -0,0 +1,79 @@+-- HaRP pattern translator produces following warnings:+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-incomplete-patterns #-}+module Darcs2RDF where++import Prelude hiding (elem)+import Text.XML.HaXml hiding (attr)+import Data.Maybe+import System.Environment (getArgs)++data Patch = Patch { patchHash :: String, patchName :: String,+                     patchDate :: String, patchAuthor :: String } deriving Show++patches (Document _ _ (Elem "changelog" _ c) _) = map patch (elems c) where+    patch el@(Elem "patch" _ _) = +        Patch (fromJust $ attr "hash" el) (fromJust $ elem "name" el)+              (fromJust $ attr "date" el) (fromJust $ attr "author" el)+        +triples :: String -> Patch -> String+triples repo (Patch hash name date author) =+    "<"++repo++"> <" ++ seeAlso ++ "> <"++month++">.\n" +++    "<"++month++"> <" ++ seeAlso ++ "> <"++day++">.\n" +++    "<"++month++"> <" ++ label ++ "> " ++ show (take 7 date') ++ ".\n" +++    "<"++day++"> <" ++ seeAlso ++ "> "++uri++".\n" +++    "<"++day++"> <" ++ label ++ "> " ++ show (take 10 date') ++ ".\n" +++    uri++" <"++label++"> " +++        ""++show name++".\n" +++    uri++" <foaf:author> "++authorURI ++ ".\n" +++    (if not $ null authorName+        then authorURI++" <foaf:name> "++show authorName ++ ".\n" else "") ++    +    authorURI++" <foaf:mbox> <mailto:"++authorMail ++ ">.\n" +++    uri++ " <dc:date> \""++date'++ "\"^^<xsd:dateTime>.\n"    +    where uri = "<darcs:"++hash++">"+          -- the following uses HaRP patterns+          [/ (/ authorName*, ' '*, '<', authorMail*, '>' /)+           | authorMail* /] = author+          authorURI = "<byemail:"++authorMail++">"+          [/ y@(/_,_,_,_/),m@(/_,_/),d@(/_,_/),h@(/_,_/),mi@(/_,_/),s@(/_,_/) /] = date+          date' = y++"-"++m++"-"++d++"T"++h++":"++mi++":"++s++"+0000"+          month = "ex:patches:" ++ take 7 date' ++ ":" ++ repo+          day = "ex:patches:" ++ take 10 date' ++ ":" ++ repo+          seeAlso = "http://www.w3.org/2000/01/rdf-schema#seeAlso"+          label = "http://www.w3.org/2000/01/rdf-schema#label"++elems :: [Content] -> [Element]+elems (CElem e : cs) = e : elems cs+elems (_ : cs)       = elems cs+elems []             = []++attr :: String -> Element -> Maybe String+attr name (Elem _ attrs _) = fmap getValue (lookup name attrs) where+    getValue (AttValue l) = concatMap getValue' l+    getValue' (Left s) = s+    getValue' (Right ref) = [unref ref]+    +elem :: String -> Element -> Maybe String+elem name (Elem _ _ cs) = findElem (elems cs) where+    findElem (Elem n _ c : _) | n == name = Just (text c)+    findElem (_ : cs') = findElem cs'+    findElem [] = Nothing+    +unref :: Reference -> Char+unref (RefChar c) = toEnum c+unref (RefEntity "apos") = '\''+unref (RefEntity "quot") = '"'+unref (RefEntity "lt") = '<'+unref (RefEntity "gt") = '>'+unref (RefEntity "amp") = '&'+unref _ = error "unimplemented reference thingie"+    +text :: [Content] -> String+text (CString _ s : cs) = s ++ text cs+text (CRef r : cs) = unref r : text cs+text (_ : _) = error "unimplemented content thingie"+text [] = ""+++main = do [repo] <- getArgs+          xml <- getContents+          putStr $ concatMap (triples repo) $ patches $ xmlParse "stdin" xml
+ Fenfire.fhs view
@@ -0,0 +1,781 @@+{-# OPTIONS_GHC -fallow-overlapping-instances -fimplicit-params #-}+module Fenfire where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import qualified Cache+import Cairo hiding (rotate)+import Vobs+import Utils+import RDF++import Paths_fenfire (getDataFileName)++import qualified Raptor (filenameToTriples, triplesToFilename, Identifier(..))++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Tree as Tree+import qualified Data.List+import Data.Set (Set)+import Data.IORef+import Data.Maybe (fromJust, isJust, isNothing, catMaybes)+import Data.Monoid(Monoid(mconcat), Dual(Dual), getDual)++import Control.Applicative+import Control.Monad (when, guard, msum)+import Control.Monad.Reader (ReaderT, runReaderT, local, ask, asks)+import Control.Monad.State (StateT, get, gets, modify, put, execStateT)+import Control.Monad.Trans (lift, liftIO)+import Control.Monad.Writer (Writer, execWriter, tell)++import Graphics.UI.Gtk hiding (Color, get, disconnect, fill)++import qualified Control.Exception+import System.Directory (canonicalizePath)+import System.Environment (getArgs, getProgName)+import System.Mem.StableName+import System.Random (randomRIO)++data ViewSettings = ViewSettings { hiddenProps :: [Node] }+data FenState = FenState { fsRotation :: Rotation, fsMark :: Mark,+                           fsFilePath :: FilePath, fsGraphModified :: Bool,+                           fsHasFocus :: Bool }++data Rotation = Rotation Graph Node Int         deriving (Eq, Show)++getRotation :: (?vs :: ViewSettings) => Graph -> Node -> Node -> Dir -> Node ->+               Maybe Rotation+getRotation graph node prop dir node' = do+    i <- Data.List.elemIndex (prop, node') (conns graph node dir)+    return (Rotation graph node +                     (i - (length (conns graph node dir) `div` 2)))+    +connsCache :: Cache.Cache (StableName Graph, (Node, Dir)) [(Node, Node)]+connsCache = Cache.newCache 10000++dc_date = URI "dc:date"++conns :: (?vs :: ViewSettings) => Graph -> Node -> Dir -> [(Node, Node)]+conns g node dir = cached where+    cached = Cache.cached (Cache.byAddress g, (node,dir)) connsCache result+    result = Data.List.sortBy cmp' list+    list = [(p,n) | (p,s) <- Map.toList $ getConns g node dir,+                    not (p `elem` hiddenProps ?vs), n <- Set.toList s]+    cmp n1 n2 | p n1 && p n2 = compare (f n1) (f n2) where+        p n = hasConn g n dc_date Pos; f n = getOne g n dc_date Pos+    cmp n1 n2 = compare (getText g n1) (getText g n2)+    cmp' (p1,n1) (p2,n2) = catOrds (cmp p1 p2) (cmp n1 n2)+    catOrds EQ o = o; catOrds o _ = o++getConn :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe (Node, Rotation)+getConn (Rotation graph node r) dir = do+    let c = conns graph node dir; i = (length c `div` 2) + r+    guard $ i >= 0 && i < length c; let (p,n) = c !! i+    rot <- getRotation graph n p (rev dir) node+    return (p,rot)+             +rotate :: (?vs :: ViewSettings) => Rotation -> Int -> Maybe Rotation+rotate (Rotation g n r) dir = let rot = Rotation g n (r+dir) in do+    guard $ any isJust [getConn rot d | d <- [Pos, Neg]]; return rot++move :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation+move rot dir = fmap snd (getConn rot dir)++getText :: Graph -> Node -> Maybe String+getText g n = fmap f $ getOne g n rdfs_label Pos where +    f (PlainLiteral s) = s; f _ = error "getText argh"+                    +setText :: Graph -> Node -> String -> Graph+setText g n t = update (n, rdfs_label, PlainLiteral t) g++nodeView :: Graph -> Node -> Vob Node+nodeView g n = rectBox $ pad 5 $ useFgColor $ multiline False 20 s+    where s = maybe (show n) id (getText g n)+    +propView :: Graph -> Node -> Vob Node+propView g n = (useFadeColor $ fill extents)+             & (pad 5 $ useFgColor $ label $ maybe (show n) id (getText g n))++++vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Color -> Color -> +                                          Color -> Color -> FenState -> Vob Node+vanishingView depth maxnodes bgColor blurBgColor focusColor blurColor+              (FenState {fsRotation=startRotation, fsMark=mark,+                         fsHasFocus=focus}) =+    runVanishing depth maxnodes view where+    -- place the center of the view and all subtrees in both directions+    view = do placeNode (if focus then Just (bgColor, focusColor) +                                  else Just (blurBgColor, blurColor))+                  startRotation+              let Rotation _ n _ = startRotation in visitNode n+              forM_ [Pos, Neg] $ \dir -> do+                  placeConns startRotation dir True+    -- place all subtrees in xdir+    placeConns rotation xdir placeFirst = withDepthIncreased 1 $ do+        when placeFirst $ placeConn rotation xdir+        forM_ [-1, 1] $ \ydir -> do+            placeConns' rotation xdir ydir+    -- place rest of the subtrees in (xdir, ydir)+    placeConns' rotation xdir ydir = withDepthIncreased 1 $+        maybeDo (rotate rotation ydir) $ \rotation' -> do+            withAngleChanged (fromIntegral ydir * mul xdir pi / 14) $ do+                placeConn rotation' xdir+                placeConns' rotation' xdir ydir+    -- place one subtree+    placeConn rotation@(Rotation graph n1 _) dir = withDepthIncreased 1 $+        maybeDo (getConn rotation dir) $ \(prop, rotation') -> do+            let Rotation _ n2 _ = rotation'+            scale' <- getScale+            withCenterMoved dir (280 * (scale'**3)) $ do+                ifUnvisited n2 $ placeNode Nothing rotation'+                let (nl,nr) = if dir==Pos then (n1,n2) else (n2,n1)+                addVob $ between (center @@ nl) (center @@ nr) $ ownSize $+                    centerVob $ scale #scale' $ propView graph prop+                addVob $ useFgColor $ stroke $+                    line (center @@ nl) (center @@ nr)+                ifUnvisited n2 $ visitNode n2 >> do+                    placeConns rotation' dir True+                    withDepthIncreased 3 $+                        placeConns rotation' (rev dir) False+    -- place one node view+    placeNode cols (Rotation graph node _) = do+        scale' <- getScale+        let f vob = case bg of Nothing -> vob+                               Just c  -> setBgColor c vob+            markColor = if node `Set.member` mark then Just (Color 1 0 0 1)+                            else Nothing+            bg = combine (fmap snd cols) markColor+            combine Nothing c = c+            combine c Nothing = c+            combine (Just c1) (Just c2) = Just $ interpolate 0.5 c1 c2+            g vob = case cols of Nothing    -> vob+                                 Just (c,_) -> frame c & vob+                where (w,h) = defaultSize vob+                      frame c = withColor #c $ fill $ +                                    moveTo (point #(0-10) #(0-10)) &+                                    lineTo (point #(w+10) #(0-10)) &+                                    lineTo (point #(w+10) #(h+10)) &+                                    lineTo (point #(0-10) #(h+10)) &+                                    lineTo (point #(0-10) #(0-10))+        placeVob $ ownSize $ scale #scale' $ keyVob node $ g $ f $ +            nodeView graph node+        +    getScale :: VV Double+    getScale = do d <- asks vvDepth; return (0.97 ** fromIntegral d)+    +    +data VVState = VVState { vvDepth :: Int, vvMaxDepth :: Int, vvMaxNodes :: Int,+                         vvX :: Double, vvY :: Double, vvAngle :: Double }+                         +type VV a = ReaderT VVState (BreadthT (StateT (Set Node) +                                          (Writer (Dual (Vob Node))))) a++runVanishing :: Int -> Int -> VV () -> Vob Node+runVanishing maxdepth maxnodes vv = comb (0,0) $ \cx -> +    let (w,h) = rcSize cx +    in getDual $ execWriter $ flip execStateT Set.empty $ execBreadthT $+           runReaderT vv $ VVState 0 maxdepth maxnodes (w/2) (h/2) 0+    +-- |Execute the passed action with the recursion depth increased by+-- the given amount of steps, if it is still smaller than the maximum+-- recursion depth.+--+withDepthIncreased :: Int -> VV () -> VV ()+withDepthIncreased n m = do+    state <- ask; let state' = state { vvDepth = vvDepth state + n }+    if vvDepth state' >= vvMaxDepth state' then return () else+        lift $ scheduleBreadthT $ flip runReaderT state' $ do+            visited <- get+            when (Set.size visited <= (4 * vvMaxNodes state') `div` 3) m+        +visitNode :: Node -> VV ()+visitNode n = modify (Set.insert n)++ifUnvisited :: Node -> VV () -> VV ()+ifUnvisited n m = do visited <- get+                     when (not $ n `Set.member` visited) m++addVob :: Vob Node -> VV ()+addVob vob = do d <- asks vvDepth; md <- asks vvMaxDepth+                mn <- asks vvMaxNodes; visited <- get+                let x = (fromIntegral (md - d) / fromIntegral (md+2))+                    vob' = if Set.size visited >= mn then invisibleVob vob+                                                     else fade x vob+                tell (Dual vob')++placeVob :: Vob Node -> VV ()+placeVob vob = do+    state <- ask+    addVob $ translate #(vvX state) #(vvY state) $ centerVob vob+        +withCenterMoved :: Dir -> Double -> VV () -> VV ()+withCenterMoved dir distance = local f where+    distance' = mul dir distance+    f s = s { vvX = vvX s + distance' * cos (vvAngle s),+              vvY = vvY s + distance' * sin (vvAngle s) }+                   +withAngleChanged :: Double -> VV () -> VV ()+withAngleChanged delta = local $ \s -> s { vvAngle = vvAngle s + delta }++++tryMove :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation+tryMove rot@(Rotation g n r) dir = maybe rot' Just (move rot dir) where+    rot' | r == nearest = Nothing+         | otherwise    = Just $ Rotation g n nearest+    nearest | r > 0     = len-1 - len `div` 2+            | otherwise = 0 - len `div` 2+    len = (length $ conns g n dir)++type URIMaker = (String, IORef Integer)++newURIMaker :: IO URIMaker+newURIMaker = do rand <- sequence [randomRIO (0,63) | _ <- [1..27::Int]]+                 let chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "+-"+                 ref <- newIORef 1+                 return ("urn:urn-5:" ++ map (chars !!) rand, ref)++newURI :: (?uriMaker :: URIMaker) => IO Node+newURI = do let (base, ref) = ?uriMaker+            i <- readIORef ref; writeIORef ref (i+1)+            return $ URI (base ++ ":" ++ show i)++newNode :: (?vs :: ViewSettings, ?uriMaker :: URIMaker) => +           Rotation -> Dir -> IO Rotation+newNode (Rotation graph node _) dir = do+    node' <- newURI+    let graph' = insert (triple dir (node, rdfs_seeAlso, node'))+               $ insert (node', rdfs_label, PlainLiteral "") graph+    return $ fromJust $ getRotation graph' node' rdfs_seeAlso (rev dir) node+    +connect :: (?vs :: ViewSettings) => Rotation -> Dir -> Mark -> Rotation+connect r _ mark | Set.null mark = r+connect (Rotation graph node _) dir mark =+    let nodes = Set.toList mark+        graph' = foldr (\n -> insert $ triple dir (node, rdfs_seeAlso, n))+                       graph nodes+    in fromJust $ getRotation graph' node rdfs_seeAlso dir (head nodes)++disconnect :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation+disconnect (Rotation graph node rot) dir = +    let+        c = conns graph node dir+        index = (length c `div` 2) + rot+        (p,n) = c !! index+        graph' = delete (triple dir (node, p, n)) graph+        index' = ((length c - 1) `div` 2) + rot+        rot' = case index' of x | x == -1                     -> rot+1+                                | x == length c - 1 && x /= 0 -> rot-1+                                | otherwise                   -> rot+    in +        if index >= 0 && index < length c +        then Just $ Rotation graph' node rot'+        else Nothing+++type Mark = Set Node++toggleMark :: Node -> Mark -> Mark+toggleMark n mark | n `Set.member` mark = Set.delete n mark+                  | otherwise           = Set.insert n mark++newGraph :: (?uriMaker :: URIMaker) => IO Rotation+newGraph = do+    home0 <- newURI++    let graph0 = listToGraph [(home0, rdfs_label, PlainLiteral "")]+        rot0 = (Rotation graph0 home0 0)++    return rot0+    +findStartRotation :: (?vs :: ViewSettings) => Graph -> Rotation+findStartRotation g = head $ catMaybes $ startNode:topic:triples where+    self = URI "ex:graph" -- ought to be what the empty URI <> is expanded to++    startNode = getRot =<< getTriple self ffv_startNode+    topic = getRot =<< getTriple self foaf_primaryTopic+    triples = map getRot $ graphToList g+    +    getTriple s p = fmap (\o -> (s,p,o)) $ getOne g s p Pos+    getRot (s,p,o) = getRotation g o p Neg s+    +    ffv_startNode = URI "http://fenfire.org/rdf-v/2003/05/ff#startNode"+    foaf_primaryTopic = URI "http://xmlns.com/foaf/0.1/primaryTopic"++loadGraph :: FilePath -> IO Graph+loadGraph fileName = do+    --file <- readFile fileName+    --graph <- fromNTriples file >>= return . reverse-}+    let convert (s,p,o) = (f s, f p, f o)+        f (Raptor.Uri s) = URI s+        f (Raptor.Literal s) = PlainLiteral s+        f (Raptor.Blank s) = URI $ "blank:" ++ s+    triples <- Raptor.filenameToTriples fileName >>= return . map convert+    return $ listToGraph triples++saveGraph :: Graph -> FilePath -> IO ()+saveGraph graph fileName = do+    --writeFile fileName $ toNTriples $ reverse graph+    let convert (s,p,o) = (f s, f p, f o)+        f (URI s) = Raptor.Uri s+        f (PlainLiteral s) = Raptor.Literal s+        triples = graphToList graph+    Raptor.triplesToFilename (map convert triples) fileName+    putStrLn $ "Saved: " ++ fileName++openFile :: (?vs :: ViewSettings) => Rotation -> FilePath -> +            IO (Rotation,FilePath)+openFile rot0 fileName0 = do+    dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen+                                   [(stockCancel, ResponseCancel),+                                    (stockOpen, ResponseAccept)]+    when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0+                                return ()+    response <- dialogRun dialog+    widgetHide dialog+    case response of+        ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog+                             graph <- loadGraph fileName+                             return (findStartRotation graph, fileName)+        _              -> return (rot0, fileName0)+        +saveFile :: Rotation -> FilePath -> Bool -> IO (FilePath,Bool)+saveFile (Rotation graph _ _) fileName0 confirmSame = do+    dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionSave+                                   [(stockCancel, ResponseCancel),+                                    (stockSave, ResponseAccept)]+    fileChooserSetDoOverwriteConfirmation dialog True+    dialogSetDefaultResponse dialog ResponseAccept+    when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0+                                return ()+    onConfirmOverwrite dialog $ do +        Just fileName <- fileChooserGetFilename dialog+        if fileName == fileName0 && not confirmSame+            then return FileChooserConfirmationAcceptFilename+            else return FileChooserConfirmationConfirm+    response <- dialogRun dialog+    widgetHide dialog+    case response of+        ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog+                             let fileName' = checkSuffix fileName+                             saveGraph graph fileName'+                             return (fileName', True)+        _              -> return (fileName0, False)+        +checkSuffix :: FilePath -> FilePath+checkSuffix s | Data.List.isSuffixOf ".nt" s = s+              | otherwise                    = s ++ ".nt"++confirmSave :: (?vs :: ViewSettings, ?pw :: Window, ?uriMaker :: URIMaker) => +               Bool -> HandlerAction FenState -> +               HandlerAction FenState+confirmSave False action = action+confirmSave True action = do+    response <- liftIO $ do+        dialog <- makeConfirmUnsavedDialog+        response' <- dialogRun dialog+        widgetHide dialog+        return response'+    case response of ResponseClose  -> action+                     ResponseAccept -> do +                         handleAction "save"+                         saved <- get >>= return . not . fsGraphModified+                         when (saved) action+                     _              -> return ()++confirmRevert :: (?vs :: ViewSettings, ?pw :: Window) => +               Bool -> HandlerAction FenState -> +               HandlerAction FenState+confirmRevert False action = action+confirmRevert True  action = do+    response <- liftIO $ do+        dialog <- makeConfirmRevertDialog+        response' <- dialogRun dialog+        widgetHide dialog+        return response'+    case response of ResponseClose  -> action+                     _              -> return ()++newState :: Rotation -> FilePath -> Bool -> FenState+newState rot fp focus = FenState rot Set.empty fp False focus++handleEvent :: (?vs :: ViewSettings, ?pw :: Window,+                ?uriMaker :: URIMaker) => Handler Event FenState+handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do+    state <- get; let rot = fsRotation state; fileName = fsFilePath state+    case key of +        x | x == "Up"    || x == "i"     -> handleAction "up"+        x | x == "Down"  || x == "comma" -> handleAction "down"+        x | x == "Left"  || x == "j"     -> handleAction "left"+        x | x == "Right" || x == "l"     -> handleAction "right"+        "O" -> handleAction "open"+        "S" -> do (fp',saved) <- liftIO $ saveFile rot fileName False+                  let modified' = fsGraphModified state && not saved+                  put $ state { fsFilePath = fp', fsGraphModified = modified' }+        _   -> unhandledEvent+handleEvent _ = unhandledEvent++handleAction :: (?vs :: ViewSettings, ?pw :: Window, +                 ?uriMaker :: URIMaker) => Handler String FenState+handleAction action = do+    FenState { fsRotation = rot@(Rotation graph node _), fsMark = mark, +               fsFilePath = filepath, fsGraphModified = modified,+               fsHasFocus=focus+             } <- get+    let m f x = maybeDo (f rot x) putRotation+        b f x = maybeDo (f rot x) $ \rot' -> do +                    putRotation rot'+                    modify $ \s -> s { fsGraphModified = modified }+        n f x = liftIO (f rot x) >>= putRotation+        o f x = putState (f rot x mark) Set.empty+    case action of+        "up"    -> b rotate (-1)    ; "down"  -> b rotate 1+        "left"  -> b tryMove Neg    ; "right" -> b tryMove Pos+        "nodel" -> n newNode Neg    ; "noder" -> n newNode Pos+        "connl" -> o connect Neg    ; "connr" -> o connect Pos+        "breakl"-> m disconnect Neg ; "breakr"-> m disconnect Pos+        "rmlit" -> putState (delLit rot) mark+        "mark"  -> putMark $ toggleMark node mark+        "new"   -> confirmSave modified $ do+            rot' <- liftIO newGraph+            put $ newState rot' "" focus+        "open"  -> confirmSave modified $ do +            (rot',fp') <- liftIO $ openFile rot filepath+            put $ newState rot' fp' focus+        "revert" | filepath /= "" -> confirmRevert modified $ do+            g' <- liftIO $ loadGraph filepath+            put $ newState (findStartRotation g') filepath focus+        "save" | filepath /= "" -> do +                     liftIO $ saveGraph graph filepath+                     modify $ \s -> s { fsGraphModified = False }+               | otherwise      -> handleAction "saveas"+        "saveas"-> do+            (fp',saved) <- liftIO $ saveFile rot filepath True+            let modified' = modified && not saved+            modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }+        "quit"  -> do confirmSave modified $ liftIO mainQuit+        "about" -> liftIO $ makeAboutDialog >>= widgetShow+        _       -> unhandledEvent+  where putRotation rot = do modify $ \state -> state { fsRotation=rot, +                                                        fsGraphModified=True }+                             setInterp True+        putMark mk      = do modify $ \state -> state { fsMark=mk }+        putState rot mk = do putMark mk; putRotation rot+        delLit (Rotation g n r) = Rotation (deleteAll n rdfs_label g) n r++makeActions actionGroup accelGroup = do+    let actionentries = +            [ ( "new"    , stockNew           )+            , ( "open"   , stockOpen          )+            , ( "save"   , stockSave          )+            , ( "saveas" , stockSaveAs        )+            , ( "revert" , stockRevertToSaved )+            , ( "quit"   , stockQuit          )+            , ( "about"  , stockAbout         )+            ]+    flip mapM actionentries $ \(name,stock) -> do +        item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label+        action <- actionNew name (siLabel $ fromJust item) Nothing (Just stock)+        actionGroupAddActionWithAccel actionGroup action Nothing+        actionSetAccelGroup action accelGroup++updateActionSensitivity actionGroup modified readable = do+    Just save <- actionGroupGetAction actionGroup "save"+    actionSetSensitive save modified+    Just revert <- actionGroupGetAction actionGroup "revert"+    actionSetSensitive revert (modified && readable)++makeBindings actionGroup bindings = do+    let bindingentries =+            [ ("noder"  , Just "_New node to right"         , +               stockMediaForward  , Just "n"              )+            , ("nodel"  , Just "N_ew node to left"          , +               stockMediaRewind   , Just "<Shift>N"       )+            , ("breakr" , Just "_Break connection to right" , +               stockGotoLast      , Just "b"              )+            , ("breakl" , Just "B_reak connection to left"  , +               stockGotoFirst     , Just "<Shift>B"       )+            , ("mark"   , Just "Toggle _mark"               ,+               stockOk            , Just "m"              )+            , ("connr"  , Just "_Connect marked to right"   ,+               stockGoForward     , Just "c"              )+            , ("connl"  , Just "C_onnect marked to left"    ,+               stockGoBack        , Just "<Shift>C"       )+            , ("rmlit"  , Just "Remove _literal text"       ,+               stockStrikethrough , Just "<Alt>BackSpace" )+            ]+    flip mapM bindingentries $ \(name,label',stock,accel) -> do +        item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label+        let label'' = maybe (siLabel $ fromJust item) id label'+        action <- actionNew name label'' Nothing (Just stock)+        actionGroupAddActionWithAccel actionGroup action accel+        actionSetAccelGroup action bindings++makeMenus actionGroup root = mapM_ (createMenu root) menuentries+    where+        leaf x = Tree.Node x []+        menuentries = [ Tree.Node "_File" (map leaf ["new","open","",+                                                     "save","saveas","revert",+                                                     "",+                                                     "quit"])+                      , Tree.Node "_Edit" (map leaf ["noder","nodel","",+                                                     "breakr","breakl","",+                                                     "mark","connr","connl","",+                                                     "rmlit"])+                      , Tree.Node "_Help" (map leaf ["about"])+                      ]+        createMenu :: MenuShellClass menu => menu -> Tree.Tree String -> IO ()+        createMenu parent (Tree.Node name children) = +            if children /= [] then do+                item <- menuItemNewWithMnemonic name+                menu <- menuNew+                mapM_ (createMenu menu) children+                menuItemSetSubmenu item menu+                menuShellAppend parent item+            else+                if name == "" then do+                    item <- separatorMenuItemNew+                    menuShellAppend parent item+                else do +                    Just action <- actionGroupGetAction actionGroup name+                    item <- actionCreateMenuItem action+                    menuShellAppend parent (castToMenuItem item)++makeToolbarItems actionGroup toolbar = do+    forM_ ["new", "open", "", "save"] $ \name -> +        if name == "" then do +            item <- separatorToolItemNew+            toolbarInsert toolbar item (-1)+        else do+            Just action <- actionGroupGetAction actionGroup name+            item <- actionCreateToolItem action+            toolbarInsert toolbar (castToToolItem item) (-1)+++main :: IO ()+main = do++    uriMaker <- newURIMaker++    let ?vs = ViewSettings { hiddenProps=[rdfs_label] }+        ?uriMaker = uriMaker in do++    -- initial state:++    args <- initGUI++    let view = vanishingView 20 30 +                   (Color 0.7 0.7 0.8 0.7) (Color 0.7 0.7 0.7 0.7)+                   (Color 0.93 0.93 1 1)   (Color 0.93 0.93 0.93 1)++    stateRef <- case args of +        [] -> do +            rot <- newGraph+            newIORef $ newState rot "" False+        xs -> do+            fileName:fileNames <- mapM canonicalizePath xs+            g' <- loadGraph fileName+            gs <- mapM loadGraph fileNames+            let rot = findStartRotation (foldl mergeGraphs g' gs)+            newIORef $ newState rot fileName False++    -- start:++    window <- makeWindow view stateRef+    widgetShowAll window++    mainGUI++makeWindow view stateRef = do++    -- main window:++    window <- windowNew+    let ?pw = window in mdo+    logo <- getDataFileName "data/logo48.png"+    Control.Exception.catch (windowSetIconFromFile window logo)+          (\e -> putStr ("Opening "++logo++" failed: ") >> print e)+    windowSetTitle window "Fenfire"+    windowSetDefaultSize window 800 550++    -- textview for editing:+    +    textView <- textViewNew+    textViewSetAcceptsTab textView False+    textViewSetWrapMode textView WrapWordChar++    -- this needs to be called whenever the node or its text changes:+    let stateChanged (FenState { fsRotation = Rotation g n _r, +                                 fsGraphModified=modified,+                                 fsFilePath=filepath }) = do+            buf <- textBufferNew Nothing+            textBufferSetText buf (maybe "" id $ getText g n)+            afterBufferChanged buf $ do +                start <- textBufferGetStartIter buf+                end   <- textBufferGetEndIter buf+                text  <- textBufferGetText buf start end True+                FenState { fsRotation = (Rotation g' n' r'),+                           fsFilePath = filepath' } +                    <- readIORef stateRef+                let g'' = setText g' n text -- buf corresponds to n, not to n'++                modifyIORef stateRef $ \s -> +                    s { fsRotation = Rotation g'' n' r', fsGraphModified=True }+                updateActionSensitivity actionGroup True (filepath' /= "")+                updateCanvas True++            textViewSetBuffer textView buf+            updateActionSensitivity actionGroup modified (filepath /= "")++    -- canvas for view:+    +    (canvas, updateCanvas, canvasAction) <- +        vobCanvas stateRef view handleEvent handleAction+                  stateChanged lightGray 0.5++    onFocusIn canvas $ \_event -> do +        modifyIORef stateRef $ \s -> s { fsHasFocus = True }+        windowAddAccelGroup window bindings+        updateCanvas True+        return True+    onFocusOut canvas $ \_event -> do +        modifyIORef stateRef $ \s -> s { fsHasFocus = False }+        windowRemoveAccelGroup window bindings+        updateCanvas True+        return True++    -- action widgets:++    accelGroup <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs+    windowAddAccelGroup window accelGroup+    -- bindings are active only when the canvas has the focus:+    bindings <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs++    actionGroup <- actionGroupNew "main"++    makeActions actionGroup accelGroup +    makeBindings actionGroup bindings++    actions <- actionGroupListActions actionGroup+    forM_ actions $ \action -> do+        name <- actionGetName action+        onActionActivate action $ canvasAction name >> return ()++    -- user interface widgets:++    menubar <- menuBarNew+    makeMenus actionGroup menubar++    toolbar <- toolbarNew+    makeToolbarItems actionGroup toolbar++    -- layout:++    canvasFrame <- frameNew+    set canvasFrame [ containerChild := canvas+                      , frameShadowType := ShadowIn +                      ]++    textViewFrame <- frameNew+    set textViewFrame [ containerChild := textView+                      , frameShadowType := ShadowIn +                      ]++    paned <- vPanedNew+    panedAdd1 paned canvasFrame+    panedAdd2 paned textViewFrame++    vbox <- vBoxNew False 0+    boxPackStart vbox menubar PackNatural 0+    boxPackStart vbox toolbar PackNatural 0+    boxPackStart vbox paned PackGrow 0+    containerSetFocusChain vbox [toWidget paned]+    +    set paned [ panedPosition := 380, panedChildResize textViewFrame := False ]++    set window [ containerChild := vbox ]++    -- start:++    readIORef stateRef >>= stateChanged+    +    widgetGrabFocus canvas++    onDelete window $ \_event -> canvasAction "quit"++    return window+++makeAboutDialog :: (?pw :: Window) => IO AboutDialog+makeAboutDialog = do+    dialog <- aboutDialogNew+    logoFilename <- getDataFileName "data/logo.svg"+    pixbuf <- Control.Exception.catch (pixbufNewFromFile logoFilename)+                  (\e -> return $ Left (undefined, show e))+    logo <- case pixbuf of Left (_,msg)  -> do +                               putStr ("Opening "++logoFilename++" failed: ")+                               putStrLn msg+                               return Nothing+                           Right pixbuf' -> return . Just =<< +                               pixbufScaleSimple pixbuf'+                                   200 (floor (200*(1.40::Double))) +                                   InterpHyper +    set dialog [ aboutDialogName := "Fenfire" +               , aboutDialogVersion := "alpha version"+               , aboutDialogCopyright := "Licensed under GNU GPL v2 or later"+               , aboutDialogComments := +                     "An application for notetaking and RDF graph browsing."+               , aboutDialogLogo := logo+               , aboutDialogWebsite := "http://fenfire.org"+               , aboutDialogAuthors := ["Benja Fallenstein", "Tuukka Hastrup"]+               , windowTransientFor := ?pw+               ]+    onResponse dialog $ \_response -> widgetHide dialog+    return dialog++makeDialog :: (?pw :: Window) => String -> [(String, ResponseId)] -> +                                 ResponseId -> IO Dialog+makeDialog title buttons preset = do+    dialog <- dialogNew+    set dialog [ windowTitle := title+               , windowTransientFor := ?pw+               , windowModal := True+               , windowDestroyWithParent := True+               , dialogHasSeparator := False+               ]+    mapM_ (uncurry $ dialogAddButton dialog) buttons+    dialogSetDefaultResponse dialog preset+    return dialog++makeConfirmUnsavedDialog :: (?pw :: Window) => IO Dialog+makeConfirmUnsavedDialog = do +    makeDialog "Confirm unsaved changes" +        [("Discard changes", ResponseClose),+         (stockCancel, ResponseCancel),+         (stockSave, ResponseAccept)]+        ResponseAccept++makeConfirmRevertDialog :: (?pw :: Window) => IO Dialog+makeConfirmRevertDialog = do+    makeDialog "Confirm revert"+        [(stockCancel, ResponseCancel),+         (stockRevertToSaved,ResponseClose)]+        ResponseCancel
+ FunctorSugar.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -fth #-} +module FunctorSugar where++import Control.Applicative+import Control.Monad+import Control.Monad.Writer+import Data.Maybe+import Language.Haskell.TH+import System.IO.Unsafe++functorCall :: Functor f => f a -> a+functorCall x = error "Eeene meene miste es rappelt in der kiste"++fzip :: Applicative f => f a -> f b -> f (a,b)+fzip a b = pure (\x y -> (x,y)) <*> a <*> b++fcurry :: Applicative f => (f (a,b) -> c) -> f a -> f b -> c+fcurry f x y = f (fzip x y)++functorSugar :: ExpQ -> ExpQ+functorSugar expQ = do exp <- expQ+                       (exp', calls) <- runWriterT (traverse exp)+                       appsE ([mkFMap $ length calls,+                               lamE (map (varP . fst) calls) $ return exp']+                            ++ map (return . snd) calls) ++mkFMap :: Int -> ExpQ+mkFMap 0 = [| pure |]+mkFMap 1 = [| fmap |]+mkFMap n = [| \f -> $(repeatFn (n-1) [| fcurry |]) +                        (fmap ($(repeatFn (n-1) [| uncurry |]) f)) |]+    where repeatFn :: Int -> ExpQ -> ExpQ+          repeatFn 1 e = e+          repeatFn n e = [| $e . $(repeatFn (n-1) e) |]++callExpr :: Exp+callExpr = unsafePerformIO $ runQ [| FunctorSugar.functorCall |]++type Binds = [(Name, Exp)]+type Traverse a = a -> WriterT Binds Q a++traverse :: Traverse Exp+traverse e = case e of+    VarE name -> return (VarE name)+    ConE name -> return (ConE name)+    LitE lit -> return (LitE lit)+    AppE e1 e2 | e1 == callExpr -> do name <- lift $ newName "call"+                                      tell [(name, e2)]+                                      return (VarE name)+    AppE e1 e2 -> liftM2 AppE (traverse e1) (traverse e2)+    InfixE el ei er -> do ei' <- traverse ei+                          el' <- maybe (return Nothing) +                                       (liftM Just . traverse) el+                          er' <- maybe (return Nothing) +                                       (liftM Just . traverse) er+                          return (InfixE el' ei' er')+    LamE pats e -> liftM (LamE pats) (traverse e)+    TupE exps -> liftM TupE (mapM traverse exps)+    LetE decls e -> liftM2 LetE (mapM traverseDec decls) (traverse e)+    ListE exps -> liftM ListE (mapM traverse exps)+    SigE e type' -> liftM (flip SigE type') (traverse e)+    DoE stmts -> liftM DoE (mapM traverseStmt stmts)+    CompE stmts -> liftM CompE (mapM traverseStmt stmts)+    e -> error ("expression type not implemented yet: " ++ show e)+    +traverseDec :: Traverse Dec+traverseDec decl = case decl of+    FunD name clauses -> liftM (FunD name) (mapM traverseClause clauses)+    ValD pat body decls -> liftM2 (ValD pat) (traverseBody body)+                                             (mapM traverseDec decls)+    SigD name type' -> return (SigD name type')+    -- ... possibly other things but I <benja> think not ... --+    d -> error ("declaration type not implemented: " ++ show d)++traverseClause :: Traverse Clause+traverseClause (Clause pats body decls) =+    liftM2 (Clause pats) (traverseBody body) (mapM traverseDec decls)+    +traverseBody :: Traverse Body+traverseBody (NormalB e) = liftM NormalB (traverse e)+traverseBody (GuardedB bs) = liftM GuardedB $ forM bs $ \(g,e) ->+    do e' <- traverse e; return (g,e')+    +traverseStmt :: Traverse Stmt+traverseStmt stmt = case stmt of+    BindS pat exp -> liftM (BindS pat) (traverse exp)+    LetS decs -> liftM LetS (mapM traverseDec decs)+    NoBindS exp -> liftM NoBindS (traverse exp)+    ParS stmts -> liftM ParS (mapM (mapM traverseStmt) stmts)++{-+CondE Exp Exp Exp+LetE [Dec] Exp+CaseE Exp [Match]+ArithSeqE Range+ListE [Exp]+SigE Exp Type+RecConE Name [FieldExp]+RecUpdE Exp [FieldExp]+-}
+ FunctorTest.fhs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}++module FunctorTest where++f x = "This is not a result value: " ++ show x++foo s = f #(bar !s !s)+bar = (+)++main = putStrLn (foo [4,3,9::Integer])
+ LICENSE view
@@ -0,0 +1,340 @@+		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++			    Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++			    NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++		     END OF TERMS AND CONDITIONS++	    How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software; you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation; either version 2 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program; if not, write to the Free Software+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ Makefile view
@@ -0,0 +1,60 @@++GHC?=ghc+GHCFLAGS=-fglasgow-exts -hide-package haskell98 -Wall -fno-warn-unused-imports -fno-warn-missing-signatures -fno-warn-orphans -fno-warn-deprecations++#GHCFLAGS+=-O -fexcess-precision -optc-ffast-math -optc-O3 +#crash: -optc-march=pentium4 -optc-mfpmath=sse++GHCCMD = $(GHC) $(GHCFLAGS)++C2HS?=c2hs+TRHSX?=trhsx++PREPROCESSED=$(patsubst %.fhs,%.hs,$(wildcard *.fhs)) \+             $(patsubst %.chs,%.hs,$(wildcard *.chs))+SOURCES=*.hs *.chs *.fhs $(PREPROCESSED)+TARGETS=functortest vobtest fenfire darcs2rdf++all: build++build:+	runghc Setup.hs build++profilable:+	rm -f $(TARGETS)+	$(MAKE) all+	rm -f $(TARGETS)+	$(MAKE) all "GHCFLAGS=-prof -auto-all -hisuf p_hi -osuf p_o $(GHCFLAGS)"+non-profilable:+	rm -f $(TARGETS)+	$(MAKE) all++functortest vobtest fenfire darcs2rdf: build++run-functortest: functortest+run-vobtest: vobtest+run-fenfire: ARGS=test.nt+run-fenfire: fenfire+run-darcs2rdf: darcs2rdf+run-%: %+	./dist/build/$</$< $(ARGS)++run-project: fenfire ../fenfire-project/project.nt darcs.nt+	./dist/build/fenfire/fenfire ../fenfire-project/project.nt darcs.nt $(ARGS)++darcs.nt: darcs2rdf _darcs/inventory+	darcs changes --xml | ./dist/build/darcs2rdf/darcs2rdf "http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs/" > darcs.nt++clean:+	rm -f $(PREPROCESSED) *.p_hi *.hi *.i *.chi Raptor.h Raptor_stub.* *.p_o *.o $(TARGETS)++# __attribute__ needs to be a no-op until c2hs learns to parse them in raptor.h+%.hs: %.chs+	$(C2HS) --cppopts '-D"__attribute__(A)= "' $<++%.hs: %.fhs+	echo "-- GENERATED file. Edit the ORIGINAL $< instead." >$@+	$(TRHSX) $< >>$@ || (rm $@ && exit 1)++dump-patches: darcs2rdf+	darcs changes --xml | ./darcs2rdf "http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs/" >> $(ARGS)
+ Preprocessor/Hsx.hs view
@@ -0,0 +1,27 @@+module Preprocessor.Hsx (+	  module Preprocessor.Hsx.Syntax+	, module Preprocessor.Hsx.Build+	, module Preprocessor.Hsx.Parser+	, module Preprocessor.Hsx.Pretty+	, module Preprocessor.Hsx.Transform+	, parseFileContents+	, parseFileContentsWithMode+	, parseFile+	) where++import Preprocessor.Hsx.Build+import Preprocessor.Hsx.Syntax+import Preprocessor.Hsx.Parser+import Preprocessor.Hsx.Pretty+import Preprocessor.Hsx.Transform++parseFile :: FilePath -> IO (ParseResult HsModule)+parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))++parseFileContents :: String -> ParseResult HsModule+parseFileContents = parseFileContentsWithMode defaultParseMode++parseFileContentsWithMode :: ParseMode -> String -> ParseResult HsModule+parseFileContentsWithMode p rawStr =+	let cleanStr = unlines [ s | s@(c:_) <- lines rawStr, c /= '#' ]+	 in parseModuleWithMode p cleanStr
+ Preprocessor/Hsx/Build.hs view
@@ -0,0 +1,235 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Build+-- Original    :  Language.Haskell.Syntax+-- Copyright   :  (c) The GHC Team, 1997-2000,+--                (c) Niklas Broberg 2004+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Build (++    -- * Syntax building functions+    name,		-- :: String -> HsName+    sym,		-- :: String -> HsName+    var,		-- :: HsName -> HsExp+    op,			-- :: HsName -> HsQOp+    qvar,		-- :: Module -> HsName -> HsExp+    pvar,		-- :: HsName -> HsPat+    app,		-- :: HsExp -> HsExp -> HsExp+    infixApp,		-- :: HsExp -> HsQOp -> HsExp -> HsExp+    appFun,		-- :: HsExp -> [HsExp] -> HsExp+    pApp,		-- :: HsName -> [HsPat] -> HsPat+    tuple,		-- :: [HsExp] -> HsExp+    pTuple,		-- :: [HsPat] -> HsPat+    varTuple,		-- :: [HsName] -> HsExp+    pvarTuple,		-- :: [HsName] -> HsPat+    function,		-- :: String -> HsExp+    strE,		-- :: String -> HsExp+    charE,		-- :: Char -> HsExp+    intE,		-- :: Integer -> HsExp+    strP,		-- :: String -> HsPat+    charP,		-- :: Char -> HsPat+    intP,		-- :: Integer -> HsPat+    doE,		-- :: [HsStmt] -> HsExp+    lamE,		-- :: SrcLoc -> [HsPat] -> HsExp -> HsExp+    letE,		-- :: [HsDecl] -> HsExp -> HsExp+    caseE,		-- :: HsExp -> [HsAlt] -> HsExp+    alt,		-- :: SrcLoc -> HsPat -> HsExp -> HsAlt+    altGW,		-- :: SrcLoc -> HsPat -> [HsStmt] -> HsExp -> HsBinds -> HsAlt+    listE,		-- :: [HsExp] -> HsExp+    eList,		-- :: HsExp+    peList,		-- :: HsPat+    paren,		-- :: HsExp -> HsExp+    pParen,		-- :: HsPat -> HsPat+    qualStmt,		-- :: HsExp -> HsStmt+    genStmt,		-- :: SrcLoc -> HsPat -> HsExp -> HsStmt+    letStmt,		-- :: [HsDecl] -> HsStmt+    binds,		-- :: [HsDecl] -> HsBinds+    noBinds,		-- :: HsBinds+    wildcard,		-- :: HsPat+    genNames,		-- :: String -> Int -> [HsName]+    +    -- * More advanced building+    sfun,		-- :: SrcLoc -> HsName -> [HsName] -> HsRhs -> HsBinds -> HsDecl+    simpleFun,		-- :: SrcLoc -> HsName -> HsName -> HsExp -> HsDecl+    patBind,		-- :: SrcLoc -> HsPat -> HsExp -> HsDecl+    patBindWhere,	-- :: SrcLoc -> HsPat -> HsExp -> [HsDecl] -> HsDecl+    nameBind,		-- :: SrcLoc -> HsName -> HsExp -> HsDecl+    metaFunction,	-- :: String -> [HsExp] -> HsExp+    metaConPat		-- :: String -> [HsPat] -> HsPat+  ) where++import Preprocessor.Hsx.Syntax++-----------------------------------------------------------------------------+-- Help functions for Abstract syntax ++name :: String -> HsName+name = HsIdent++sym :: String -> HsName+sym = HsSymbol++var :: HsName -> HsExp+var = HsVar . UnQual++op :: HsName -> HsQOp+op = HsQVarOp . UnQual++qvar :: Module -> HsName -> HsExp+qvar m n = HsVar $ Qual m n++pvar :: HsName -> HsPat+pvar = HsPVar++app :: HsExp -> HsExp -> HsExp+app = HsApp++infixApp :: HsExp -> HsQOp -> HsExp -> HsExp+infixApp = HsInfixApp++appFun :: HsExp -> [HsExp] -> HsExp+appFun f [] = f+appFun f (a:as) = appFun (app f a) as++pApp :: HsName -> [HsPat] -> HsPat+pApp n ps = HsPApp (UnQual n) ps++tuple :: [HsExp] -> HsExp+tuple = HsTuple++pTuple :: [HsPat] -> HsPat+pTuple = HsPTuple++varTuple :: [HsName] -> HsExp+varTuple ns = tuple $ map var ns++pvarTuple :: [HsName] -> HsPat+pvarTuple ns = pTuple $ map pvar ns++function :: String -> HsExp+function = var . HsIdent++strE :: String -> HsExp+strE = HsLit . HsString++charE :: Char -> HsExp+charE = HsLit . HsChar++intE :: Integer -> HsExp+intE = HsLit . HsInt++strP :: String -> HsPat+strP = HsPLit . HsString++charP :: Char -> HsPat+charP = HsPLit . HsChar++intP :: Integer -> HsPat+intP = HsPLit . HsInt++doE :: [HsStmt] -> HsExp+doE = HsDo++lamE :: SrcLoc -> [HsPat] -> HsExp -> HsExp+lamE = HsLambda++letE :: [HsDecl] -> HsExp -> HsExp+letE ds e = HsLet (binds ds) e++caseE :: HsExp -> [HsAlt] -> HsExp+caseE = HsCase++alt :: SrcLoc -> HsPat -> HsExp -> HsAlt+alt s p e = HsAlt s p (HsUnGuardedAlt e) noBinds++altGW :: SrcLoc -> HsPat -> [HsStmt] -> HsExp -> HsBinds -> HsAlt+altGW s p gs e w = HsAlt s p (gAlt s gs e) w++unGAlt :: HsExp -> HsGuardedAlts+unGAlt = HsUnGuardedAlt++gAlts :: SrcLoc -> [([HsStmt],HsExp)] -> HsGuardedAlts+gAlts s as = HsGuardedAlts $ map (\(gs,e) -> HsGuardedAlt s gs e) as++gAlt :: SrcLoc -> [HsStmt] -> HsExp -> HsGuardedAlts+gAlt s gs e = gAlts s [(gs,e)]++listE :: [HsExp] -> HsExp+listE = HsList++eList :: HsExp+eList = HsList []++peList :: HsPat+peList = HsPList []++paren :: HsExp -> HsExp+paren = HsParen++pParen :: HsPat -> HsPat+pParen = HsPParen++qualStmt :: HsExp -> HsStmt+qualStmt = HsQualifier++genStmt :: SrcLoc -> HsPat -> HsExp -> HsStmt+genStmt = HsGenerator++letStmt :: [HsDecl] -> HsStmt+letStmt ds = HsLetStmt $ binds ds++binds :: [HsDecl] -> HsBinds+binds = HsBDecls++noBinds :: HsBinds+noBinds = binds []++wildcard :: HsPat+wildcard = HsPWildCard++genNames :: String -> Int -> [HsName]+genNames s k = [ HsIdent $ s ++ show i | i <- [1..k] ]++-------------------------------------------------------------------------------+-- Some more specialised help functions ++-- | A function with a single "match"+sfun :: SrcLoc -> HsName -> [HsName] -> HsRhs -> HsBinds -> HsDecl+sfun s f pvs rhs bs = HsFunBind [HsMatch s f (map pvar pvs) rhs bs]++-- | A function with a single "match", a single argument, no guards+-- and no where declarations+simpleFun :: SrcLoc -> HsName -> HsName -> HsExp -> HsDecl+simpleFun s f a e = let rhs = HsUnGuardedRhs e+		     in sfun s f [a] rhs noBinds++-- | A pattern bind where the pattern is a variable, and where+-- there are no guards and no 'where' clause.+patBind :: SrcLoc -> HsPat -> HsExp -> HsDecl+patBind s p e = let rhs = HsUnGuardedRhs e+		 in HsPatBind s p rhs noBinds++patBindWhere :: SrcLoc -> HsPat -> HsExp -> [HsDecl] -> HsDecl+patBindWhere s p e ds = let rhs = HsUnGuardedRhs e+			 in HsPatBind s p rhs (binds ds)++nameBind :: SrcLoc -> HsName -> HsExp -> HsDecl+nameBind s n e = patBind s (pvar n) e++-- meta-level functions, i.e. functions that represent functions, +-- and that take arguments representing arguments... whew!+metaFunction :: String -> [HsExp] -> HsExp+metaFunction s es = mf s (reverse es)+  where mf s []     = var $ name s+	mf s (e:es) = app (mf s es) e+++metaConPat :: String -> [HsPat] -> HsPat+metaConPat s ps = pApp (name s) ps
+ Preprocessor/Hsx/Lexer.hs view
@@ -0,0 +1,829 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Lexer+-- Original    :  Language.Haskell.Lexer+-- Copyright   :  (c) The GHC Team, 1997-2000+--		  (c) Niklas Broberg, 2004+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Lexer for Haskell, with some extensions.+--+-----------------------------------------------------------------------------++-- 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 Preprocessor.Hsx.Lexer (Token(..), lexer) where++import Preprocessor.Hsx.ParseMonad++import Data.Char+import Data.Ratio++data Token+        = VarId String+        | QVarId (String,String)+        | IDupVarId (String)		-- duplicable implicit parameter+        | ILinVarId (String)		-- linear implicit parameter+	| ConId String+        | QConId (String,String)+	| DVarId [String]		-- to enable varid's with '-' in them+        | VarSym String+        | ConSym String+        | QVarSym (String,String)+        | QConSym (String,String)+	| IntTok Integer+	| FloatTok Rational+	| Character Char+        | StringTok String+        | Pragma String++-- Symbols++	| LeftParen+	| RightParen+	| LeftHashParen+	| RightHashParen+	| SemiColon+        | LeftCurly+        | RightCurly+        | VRightCurly			-- a virtual close brace+        | LeftSquare+        | RightSquare+	| Comma+        | Underscore+        | BackQuote++-- Reserved operators++	| Dot			-- reserved for use with 'forall x . x'+	| DotDot+	| Colon+	| DoubleColon+	| Equals+	| Backslash+	| Bar+	| LeftArrow+	| RightArrow+	| At+	| Tilde+	| DoubleArrow+	| Minus+	| Exclamation+	+-- Template Haskell+	| THExpQuote 		-- [| or [e|+	| THPatQuote		-- [p|+	| THDecQuote		-- [d|+	| THTypQuote		-- [t|         +	| THCloseQuote		-- |]+	| THIdEscape (String)	-- $x+	| THParenEscape		-- $( +	| THReifyType+	| THReifyDecl+	| THReifyFixity++-- HaRP+	| RPOpen		-- [/+	| RPClose		-- /]+	| RPSeqOpen		-- (/+	| RPSeqClose		-- /)+	| RPStar		-- *+	| RPStarG		-- *!+	| RPOpt			-- ?+	| RPOptG		-- ?!+	| RPPlus		-- ++	| RPPlusG		-- +!+	| RPEither		-- |+	| RPCAt			-- @:++-- Hsx+	| XCodeTagOpen		-- <%+	| XCodeTagClose		-- %>+	| XStdTagOpen		-- <+	| XStdTagClose		-- >+	| XCloseTagOpen		-- </+	| XEmptyTagClose	-- />+	| XPcdata String++-- Functor sugar+        | Hash                  -- #++-- Reserved Ids++	| KW_As+	| KW_Case+	| KW_Class+	| KW_Data+	| KW_Default+	| KW_Deriving+	| KW_DLet		-- implictit parameter binding+	| KW_Do+	| KW_MDo+	| KW_Else+	| KW_Forall		-- universal/existential types+        | KW_Hiding+	| 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+	| KW_With		-- implicit parameter binding+	| KW_Qualified++				-- FFI+	| KW_Foreign+	| KW_Export+	| KW_Safe+	| KW_Unsafe+	| KW_Threadsafe+	| KW_StdCall+	| KW_CCall++        | EOF+        deriving (Eq,Show)++reserved_ops :: [(String,Token)]+reserved_ops = [+ ( ".",	 Dot ),+ ( "..", DotDot ),+ ( ":",  Colon ),+ ( "::", DoubleColon ),+ ( "=",  Equals ),+ ( "\\", Backslash ),+ ( "|",  Bar ),+ ( "<-", LeftArrow ),+ ( "->", RightArrow ),+ ( "@",  At ),+ ( "~",  Tilde ),+ ( "=>", DoubleArrow ),+ ( "#",  Hash )+ ]++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 ),+ ( "data",      KW_Data ),+ ( "default",   KW_Default ),+ ( "deriving",  KW_Deriving ),+ ( "dlet",	KW_DLet ),		-- implicit parameters (hugs)+ ( "do",        KW_Do ),+ ( "else",      KW_Else ),+ ( "forall",	KW_Forall ),		-- universal/existential quantification+ ( "if",    	KW_If ),+ ( "import",    KW_Import ),+ ( "in", 	KW_In ),+ ( "infix", 	KW_Infix ),+ ( "infixl", 	KW_InfixL ),+ ( "infixr", 	KW_InfixR ),+ ( "instance",  KW_Instance ),+ ( "let", 	KW_Let ),+ ( "mdo",       KW_MDo ),+ ( "module", 	KW_Module ),+ ( "newtype",   KW_NewType ),+ ( "of", 	KW_Of ),+ ( "then", 	KW_Then ),+ ( "type", 	KW_Type ),+ ( "where", 	KW_Where ),+ ( "with",	KW_With ),		-- implicit parameters++-- Template Haskell+ ( "reifyDecl", THReifyDecl ),+ ( "reifyType", THReifyType ),+ ( "reifyFixity", THReifyFixity ),++-- FFI+ ( "foreign", 	KW_Foreign )+ ]+++special_varids :: [(String,Token)]+special_varids = [+ ( "as", 	KW_As ),+ ( "qualified", KW_Qualified ),+ ( "hiding", 	KW_Hiding ),++-- FFI+ ( "export",	KW_Export),+ ( "safe",	KW_Safe),+ ( "unsafe",	KW_Unsafe),+ ( "threadsafe", KW_Threadsafe),+ ( "stdcall",	KW_StdCall),+ ( "ccall",	KW_CCall)+ ]++isIdent, isHSymbol :: Char -> Bool+isIdent   c = isAlpha c || isDigit c || c == '\'' || c == '_'+isHSymbol 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, ws) <- lexWhiteSpace bol+	-- take care of whitespace in PCDATA+	ec <- getExtContext+	case ec of+	 -- if there was no linebreak, and we are lexing PCDATA,+	 -- then we want to care about the whitespace+	 Just ChildCtxt | not bol && ws -> return $ XPcdata " "+	 _ -> do startToken+		 if bol then lexBOL else lexToken ++lexWhiteSpace :: Bool -> Lex a (Bool, Bool)+lexWhiteSpace bol = do+	s <- getInput+	case s of+	    '{':'-':c:_ | c /= '#' -> do+		discard 2+		bol <- lexNestedComment bol+		(bol, _) <- lexWhiteSpace bol+		return (bol, True)+	    '-':'-':s | all (== '-') (takeWhile isHSymbol s) -> do+		lexWhile (== '-')+		lexWhile (/= '\n')+		lexNewline+		lexWhiteSpace True+		return (True, True)+	    '\n':_ -> do+		lexNewline+		lexWhiteSpace True+		return (True, True)+	    '\t':_ -> do+		lexTab+		(bol, _) <- lexWhiteSpace bol+		return (bol, True)		+	    c:_ | isSpace c -> do+		discard 1+		(bol, _) <- lexWhiteSpace bol+		return (bol, True)+	    _ -> return (bol, False)+	    +lexPragma :: String -> Lex a String+lexPragma str = do+	s <- getInput+	case s of+	    '#':'-':'}':_ -> do+	        discard 3 >> return str+	    '\t':_ -> lexTab >> lexPragma (str ++ "\t")+	    '\n':_ -> lexNewline >> lexPragma (str ++ "\n")+	    c:_ -> discard 1 >> lexPragma (str ++ [c])+	    []  -> fail "Unterminated pragma"++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+	ec <- getExtContext+	case ec of+	 Just HarpCtxt 	   -> lexHarpToken+	 Just TagCtxt	   -> lexTagCtxt+	 Just CloseTagCtxt -> lexCloseTagCtxt+	 Just ChildCtxt    -> lexChildCtxt+	 Just CodeTagCtxt  -> lexCodeTagCtxt+	 _ 		   -> lexStdToken+++lexChildCtxt :: Lex a Token+lexChildCtxt = do+    s <- getInput+    case s of+    	'<':'%':_ -> do discard 2+    			pushExtContextL CodeTagCtxt+    			return XCodeTagOpen+    	'<':'/':_ -> do discard 2+    			popExtContextL "lexChildCtxt"+    			pushExtContextL CloseTagCtxt+    			return XCloseTagOpen+    	'<':_	  -> do discard 1+    			pushExtContextL TagCtxt+    			return XStdTagOpen+    	'[':'/':_ -> do discard 2+    			pushExtContextL HarpCtxt+    			return RPOpen+    	_	  -> lexPCDATA+++lexPCDATA :: Lex a Token+lexPCDATA = do+    s <- getInput+    case s of+    	[] -> return EOF+    	_  -> case s of+		'\n':_ -> do+			x <- lexNewline >> lexPCDATA+			case x of+			 XPcdata p -> return $ XPcdata $ '\n':p+			 EOF -> return EOF+		'<':_ -> return $ XPcdata ""+		'[':'/':_ -> return $ XPcdata ""+		'[':s' -> do discard 1+			     pcd <- lexPCDATA+			     case pcd of+			      XPcdata pcd' -> return $ XPcdata $ '[':pcd'+			      EOF -> return EOF+		_ -> do let pcd = takeWhile (\c -> not $ elem c "<[\n") s+        	     	    l = length pcd+    	         	discard l+			x <- lexPCDATA+			case x of+			 XPcdata pcd' -> return $ XPcdata $ pcd ++ pcd'+			 EOF -> return EOF+++lexCodeTagCtxt :: Lex a Token+lexCodeTagCtxt = do+    s <- getInput+    case s of+        '%':'>':_ -> do discard 2+        		popExtContextL "lexCodeTagContext"+        		return XCodeTagClose+        _	  -> lexStdToken++lexCloseTagCtxt :: Lex a Token+lexCloseTagCtxt = do+    s <- getInput+    case s of+    	'>':_ 	  -> do discard 1+    			popExtContextL "lexCloseTagCtxt"+    			return XStdTagClose+    	_	  -> lexStdToken++lexTagCtxt :: Lex a Token+lexTagCtxt = do+    s <- getInput+    case s of+    	'/':'>':_ -> do discard 2+    			popExtContextL "lexTagCtxt: Empty tag"+    			return XEmptyTagClose+    	'>':_	  -> do discard 1+    			popExtContextL "lexTagCtxt: Standard tag"+    			pushExtContextL ChildCtxt+    			return XStdTagClose+    	_	  -> lexStdToken++lexHarpToken :: Lex a Token+lexHarpToken = do+    s <- getInput+    case s of+    	'[':'/':_ -> do discard 2+    			pushExtContextL HarpCtxt+    			return RPOpen+    	'/':']':_ -> do discard 2+    			popExtContextL "lexHarpToken"+    			return RPClose+    	'(':'/':_ -> do discard 2+    			return RPSeqOpen+    	'/':')':_ -> do discard 2+    			return RPSeqClose+    	'*':'!':_ -> do discard 2+    			return RPStarG+    	'*':_ 	  -> do discard 1+    			return RPStar+    	'+':'!':_ -> do discard 2+    			return RPPlusG+    	'+':_	  -> do discard 1+    			return RPPlus+    	'|':_	  -> do discard 1+    			return RPEither+    	'?':'!':_ -> do discard 2+    			return RPOptG+    	'?':_	  -> do discard 1+    			return RPOpt+    	'@':':':_ -> do discard 2+    			return RPCAt+    	_	  -> lexStdToken++lexStdToken :: Lex a Token+lexStdToken = do+    s <- getInput+    case s of+        [] -> return EOF++        '{':'-':'#':_ -> do+	        discard 3+	        pragma <- lexPragma "" +	        return (Pragma pragma)++	'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)+	+	-- implicit parameters+	'?':c:_ | isLower c -> do+			discard 1+			id <- lexWhile isIdent+			return $ IDupVarId id++	'%':c:_ | isLower c -> do+			discard 1+			id <- lexWhile isIdent+			return $ ILinVarId id+	-- end implicit parameters++	-- harp+	'[':'/':_ -> do+			discard 2+			pushExtContextL HarpCtxt+			return RPOpen			+	+	-- template haskell+	'[':'|':_ -> do+			discard 2+			return $ THExpQuote+	+	'[':c:'|':_ | c == 'e' -> do+			discard 3+			return $ THExpQuote+		    | c == 'p' -> do+		    	discard 3+		    	return THPatQuote+		    | c == 'd' -> do+		    	discard 3+		    	return THDecQuote+		    | c == 't' -> do+		    	discard 3+		    	return THTypQuote+		    	+	'|':']':_ -> do discard 2+		        return THCloseQuote+		      +	'$':c:_ | isLower c -> do+			discard 1+			id <- lexWhile isIdent+			return $ THIdEscape id+		| c == '(' -> do+			discard 2+			return THParenEscape+	-- end template haskell+	+	-- hsx+	'<':'%':_ -> do discard 2+			pushExtContextL CodeTagCtxt+			return XCodeTagOpen+	'<':c:_ | isAlpha c -> do discard 1+				  pushExtContextL TagCtxt+				  return XStdTagOpen+	-- end hsx+	+	'(':'#':_ -> do discard 2 >> return LeftHashParen+	+	'#':')':_ -> do discard 2 >> return RightHashParen+	+	c:_ | isDigit c -> lexDecimalOrFloat++	    | isUpper c -> lexConIdOrQual ""++	    | isLower c || c == '_' -> do+		idents <- lexIdents+		case idents of+		 [ident] -> return $ case lookup ident (reserved_ids ++ special_varids) of+				      Just keyword -> keyword+				      Nothing -> VarId ident+		 _ -> return $ DVarId idents++	    | isHSymbol c -> do+		sym <- lexWhile isHSymbol+		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 "lexStdToken"+			    return RightCurly++		    '\'' -> do+			    c2 <- lexChar+			    matchChar '\'' "Improperly terminated character constant"+			    return (Character c2)++		    '"' ->  lexString++		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")++      where lexIdents :: Lex a [String]+	    lexIdents = do+		ident <- lexWhile isIdent+		s <- getInput+		case s of+		 '-':c:_ | isIdent c -> do +				discard 1+				idents <- lexIdents+				return $ ident : idents+		 _ -> return [ident]++++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'++	     | isHSymbol c -> do	-- qualified symbol?+		discard 1+		sym <- lexWhile isHSymbol+		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 <= 0x01FFFF = 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)
+ Preprocessor/Hsx/ParseMonad.hs view
@@ -0,0 +1,292 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.ParseMonad+-- Original    :  Language.Haskell.ParseMonad+-- Copyright   :  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Monads for the Haskell parser and lexer.+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.ParseMonad(+		-- * Parsing+		P, ParseResult(..), atSrcLoc, LexContext(..),+		ParseMode(..), defaultParseMode,+		runParserWithMode, runParser,+		getSrcLoc, pushCurrentContext, popContext,+		-- * Lexing+		Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,+		alternative, checkBOL, setBOL, startToken, getOffside,+		pushContextL, popContextL,+		-- * Harp/Hsx+		ExtContext(..),+		pushExtContextL, popExtContextL, getExtContext,+		getModuleName+	) where++import Preprocessor.Hsx.Syntax(SrcLoc(..))++import Data.List ( intersperse )++-- | The result of a parse.+data ParseResult a+	= ParseOk a		-- ^ The parse succeeded, yielding a value.+	| ParseFailed SrcLoc String+				-- ^ The parse failed at the specified+				-- source location, with an error message.+	deriving Show++-- internal version+data ParseStatus a = Ok ParseState a | Failed SrcLoc String+	deriving Show++data LexContext = NoLayout | Layout Int+	deriving (Eq,Ord,Show)+	+data ExtContext = CodeCtxt | HarpCtxt | TagCtxt | ChildCtxt +		| CloseTagCtxt | CodeTagCtxt+	deriving (Eq,Ord,Show)++type ParseState = ([LexContext],[ExtContext])++indentOfParseState :: ParseState -> Int+indentOfParseState (Layout n:_,_) = n+indentOfParseState _            = 0++-- | Static parameters governing a parse.+-- More to come later, e.g. literate mode, language extensions.++data ParseMode = ParseMode {+		-- | original name of the file being parsed+		parseFilename :: String+		}++-- | Default parameters for a parse,+-- currently just a marker for an unknown filename.++defaultParseMode :: ParseMode+defaultParseMode = ParseMode {+		parseFilename = "<unknown>.hs"+		}++-- | Monad for parsing++newtype P a = P { runP ::+		        String		-- input string+		     -> Int		-- current column+		     -> Int		-- current line+		     -> SrcLoc		-- location of last token read+		     -> ParseState	-- layout info.+		     -> ParseMode	-- parse parameters+		     -> ParseStatus a+		}++runParserWithMode :: ParseMode -> P a -> String -> ParseResult a+runParserWithMode mode (P m) s = case m s 0 1 start ([],[]) mode of+	Ok _ a -> ParseOk a+	Failed loc msg -> ParseFailed loc msg+    where start = SrcLoc {+		srcFilename = parseFilename mode,+		srcLine = 1,+		srcColumn = 1+	}++runParser :: P a -> String -> ParseResult a+runParser = runParserWithMode defaultParseMode++instance Monad P where+	return a = P $ \_i _x _y _l s _m -> Ok s a+	P m >>= k = P $ \i x y l s mode ->+		case m i x y l s mode of+		    Failed loc msg -> Failed loc msg+		    Ok s' a -> runP (k a) i x y l s' mode+	fail s = P $ \_r _col _line loc _stk _m -> Failed loc s++atSrcLoc :: P a -> SrcLoc -> P a+P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc++getSrcLoc :: P SrcLoc+getSrcLoc = P $ \_i _x _y l s _m -> Ok s l++getModuleName :: P String+getModuleName = P $ \_i _x _y _l s m -> +    let fn = parseFilename m+    	mn = concat $ intersperse "." $ splitPath fn+  	+	splitPath :: String -> [String]+	splitPath ""   = []+   	splitPath str  = let (l,str') = break ('\\'==) str+			  in case str' of +			      []      -> [removeSuffix l]+			      (_:str'') -> l : splitPath str''+	+	removeSuffix l = reverse $ tail $ dropWhile ('.'/=) $ reverse l++     in Ok s mn++-- Enter a new layout context.  If we are already in a layout context,+-- ensure that the new indent is greater than the indent of that context.+-- (So if the source loc is not to the right of the current indent, an+-- empty list {} will be inserted.)++pushCurrentContext :: P ()+pushCurrentContext = do+	loc <- getSrcLoc+	indent <- currentIndent+	pushContext (Layout (srcColumn loc))++currentIndent :: P Int+currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk)++pushContext :: LexContext -> P ()+pushContext ctxt =+--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $+	P $ \_i _x _y _l (s, e) _m -> Ok (ctxt:s, e) ()++popContext :: P ()+popContext = P $ \_i _x _y _l stk _m ->+      case stk of+   	(_:s, e) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $+            Ok (s, e) ()+        ([],_)    -> error "Internal error: empty context in popContext"+++-- HaRP/Hsx+pushExtContext :: ExtContext -> P ()+pushExtContext ctxt = P $ \_i _x _y _l (s, e) _m -> Ok (s, ctxt:e) ()++popExtContext :: P ()+popExtContext = P $ \_i _x _y _l (s, e) _m ->+	case e of+	 (_:e') -> +	   Ok (s, e') ()+	 [] -> error "Internal error: empty context in popExtContext"+++-- Monad for lexical analysis:+-- a continuation-passing version of the parsing monad++newtype Lex r a = Lex { runL :: (a -> P r) -> P r }++instance Monad (Lex r) where+	return a = Lex $ \k -> k a+	Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)+	Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)+	fail s = Lex $ \_ -> fail s++-- Operations on this monad++getInput :: Lex r String+getInput = Lex $ \cont -> P $ \r -> runP (cont r) r++-- | Discard some input characters (these must not include tabs or newlines).++discard :: Int -> Lex r ()+discard n = Lex $ \cont -> P $ \r x -> runP (cont ()) (drop n r) (x+n)++-- | Discard the next character, which must be a newline.++lexNewline :: Lex a ()+lexNewline = Lex $ \cont -> P $ \(_:r) _x y -> runP (cont ()) r 1 (y+1)++-- | Discard the next character, which must be a tab.++lexTab :: Lex a ()+lexTab = Lex $ \cont -> P $ \(_:r) x -> runP (cont ()) r (nextTab x)++nextTab :: Int -> Int+nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)++tAB_LENGTH :: Int+tAB_LENGTH = 8 :: Int++-- Consume and return the largest string of characters satisfying p++lexWhile :: (Char -> Bool) -> Lex a String+lexWhile p = Lex $ \cont -> P $ \r x ->+	let (cs,rest) = span p r in+	runP (cont cs) rest (x + length cs)++-- An alternative scan, to which we can return if subsequent scanning+-- is unsuccessful.++alternative :: Lex a v -> Lex a (Lex a v)+alternative (Lex v) = Lex $ \cont -> P $ \r x y ->+	runP (cont (Lex $ \cont' -> P $ \_r _x _y ->+		runP (v cont') r x y)) r x y++-- The source location is the coordinates of the previous token,+-- or, while scanning a token, the start of the current token.++-- col is the current column in the source file.+-- We also need to remember between scanning tokens whether we are+-- somewhere at the beginning of the line before the first token.+-- This could be done with an extra Bool argument to the P monad,+-- but as a hack we use a col value of 0 to indicate this situation.++-- Setting col to 0 is used in two places: just after emitting a virtual+-- close brace due to layout, so that next time through we check whether+-- we also need to emit a semi-colon, and at the beginning of the file,+-- by runParser, to kick off the lexer.+-- Thus when col is zero, the true column can be taken from the loc.++checkBOL :: Lex a Bool+checkBOL = Lex $ \cont -> P $ \r x y loc ->+		if x == 0 then runP (cont True) r (srcColumn loc) y loc+			else runP (cont False) r x y loc++setBOL :: Lex a ()+setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0++-- Set the loc to the current position++startToken :: Lex a ()+startToken = Lex $ \cont -> P $ \s x y _ stk mode ->+	let loc = SrcLoc {+		srcFilename = parseFilename mode,+		srcLine = y,+		srcColumn = x+	} in+	runP (cont ()) s x y loc stk mode++-- Current status with respect to the offside (layout) rule:+-- LT: we are to the left of the current indent (if any)+-- EQ: we are at the current indent (if any)+-- GT: we are to the right of the current indent, or not subject to layout++getOffside :: Lex a Ordering+getOffside = Lex $ \cont -> P $ \r x y loc stk ->+		runP (cont (compare x (indentOfParseState stk))) r x y loc stk++pushContextL :: LexContext -> Lex a ()+pushContextL ctxt = Lex $ \cont -> P $ \r x y loc (stk, e) ->+		runP (cont ()) r x y loc (ctxt:stk, e)++popContextL :: String -> Lex a ()+popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of+		(_:ctxt, e) -> runP (cont ()) r x y loc (ctxt, e)+		([], _)     -> error ("Internal error: empty context in " ++ fn)++-- Harp/Hsx++getExtContext :: Lex a (Maybe ExtContext)+getExtContext = Lex $ \cont -> P $ \r x y loc stk@(_, e) ->+		let me = case e of+			  [] -> Nothing+			  (c:_) -> Just c+		in runP (cont me) r x y loc stk++pushExtContextL :: ExtContext -> Lex a ()+pushExtContextL ec = Lex $ \cont -> P $ \r x y loc (s, e) ->+		runP (cont ()) r x y loc (s, ec:e)++popExtContextL :: String -> Lex a ()+popExtContextL fn = Lex $ \cont -> P $ \r x y loc stk@(s,e) -> case e of+			(_:ec) -> runP (cont ()) r x y loc (s,ec)+			[]       -> error ("Internal error: empty tag context in " ++ fn)
+ Preprocessor/Hsx/ParseUtils.hs view
@@ -0,0 +1,548 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.ParseUtils+-- Original    :  Language.Haskell.ParseUtils+-- Copyright   :  (c) Niklas Broberg 2004,+-- 		  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Utilities for the Haskell-exts parser.+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.ParseUtils (+	  splitTyConApp		-- HsType -> P (HsName,[HsType])+	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp+	, checkPrec		-- Integer -> P Int+	, checkContext		-- HsType -> P HsContext+	, checkAssertion	-- HsType -> P HsAsst+	, checkDataHeader	-- HsType -> P (HsContext,HsName,[HsName])+	, checkClassHeader	-- HsType -> P (HsContext,HsName,[HsName])+	, checkInstHeader	-- HsType -> P (HsContext,HsQName,[HsType])+	, checkPattern		-- HsExp -> P HsPat+	, checkExpr		-- HsExp -> P HsExp+	, checkValDef		-- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl+	, checkClassBody	-- [HsDecl] -> P [HsDecl]+	, checkUnQual		-- HsQName -> P HsName+	, checkRevDecls		-- [HsDecl] -> P [HsDecl]+	, getGConName		-- HsExp -> P HsQName+	, mkHsTyForall		-- Maybe [HsName] -> HsContext -> HsType -> HsType +	-- HaRP+	, checkRPattern		-- HsExp -> P HsRPat+	-- Hsx+	, checkEqNames		-- HsXName -> HsXName -> P HsXName+	, mkPageModule		-- HsExp -> P HsModule+	, mkPage		-- HsModule -> SrcLoc -> HsExp -> P HsModule+	, mkDVar		-- [String] -> String+	, mkDVarExpr		-- [String] -> HsExp+	) where++import Preprocessor.Hsx.Syntax+import Preprocessor.Hsx.ParseMonad+import Preprocessor.Hsx.Pretty+import Preprocessor.Hsx.Build++import Data.List (intersperse)++splitTyConApp :: HsType -> P (HsName,[HsType])+splitTyConApp t0 = split t0 []+ where+	split :: HsType -> [HsType] -> P (HsName,[HsType])+	split (HsTyApp t u) ts = split t (u:ts)+	split (HsTyCon (UnQual t)) ts = return (t,ts)+        split (HsTyInfix a op b) ts = split (HsTyCon op) (a:b:ts)+	split _ _ = fail "Illegal data/newtype declaration"++-----------------------------------------------------------------------------+-- Various Syntactic Checks++checkContext :: HsType -> P HsContext+checkContext (HsTyTuple Boxed ts) =+	mapM checkAssertion ts+checkContext t = do+	c <- checkAssertion t+	return [c]++-- Changed for multi-parameter type classes.+-- Further changed for implicit parameters.++checkAssertion :: HsType -> P HsAsst+checkAssertion (HsTyPred p@(HsIParam n t)) = return p+checkAssertion t = checkAssertion' [] t+	where	checkAssertion' ts (HsTyCon c) = return $ HsClassA c ts+		checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a+                checkAssertion' ts (HsTyInfix a op b) = checkAssertion' (a:b:ts) (HsTyCon op)+		checkAssertion' _ _ = fail "Illegal class assertion"+++checkDataHeader :: HsType -> P (HsContext,HsName,[HsName])+checkDataHeader (HsTyForall Nothing cs t) = do+	(c,ts) <- checkSimple "data/newtype" t []+	return (cs,c,ts)+checkDataHeader t = do+	(c,ts) <- checkSimple "data/newtype" t []+	return ([],c,ts)++checkClassHeader :: HsType -> P (HsContext,HsName,[HsName])+checkClassHeader (HsTyForall Nothing cs t) = do+	(c,ts) <- checkSimple "class" t []+	return (cs,c,ts)+checkClassHeader t = do+	(c,ts) <- checkSimple "class" t []+	return ([],c,ts)++checkSimple :: String -> HsType -> [HsName] -> P (HsName,[HsName])+checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)+checkSimple _  (HsTyInfix (HsTyVar a) (UnQual t) (HsTyVar b)) xs = return (t,a:b:xs)+checkSimple _kw (HsTyCon (UnQual t))   xs = return (t,xs)+checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration")++checkInstHeader :: HsType -> P (HsContext,HsQName,[HsType])+checkInstHeader (HsTyForall Nothing cs t) = do+	(c,ts) <- checkInsts t []+	return (cs,c,ts)+checkInstHeader t = do+	(c,ts) <- checkInsts t []+	return ([],c,ts)+	++checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType]))+checkInsts (HsTyApp l t) ts = checkInsts l (t:ts)+checkInsts (HsTyCon c)   ts = return (c,ts)+checkInsts _ _ = fail "Illegal instance declaration"++{-+checkInst :: HsType -> P ()+checkInst (HsTyApp l _) = checkInst l+checkInst (HsTyVar _)   = fail "Illegal instance declaration"+checkInst _             = return ()+-}++-----------------------------------------------------------------------------+-- Checking Patterns.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: HsExp -> P HsPat+checkPattern e = checkPat e []++checkPat :: HsExp -> [HsPat] -> P HsPat+checkPat (HsCon c) args = return (HsPApp c args)+checkPat (HsApp f x) args = do+	x <- checkPat x []+	checkPat f (x:args)+checkPat e [] = case e of+	HsVar (UnQual x)   -> return (HsPVar x)+	HsLit l            -> return (HsPLit l)+	HsInfixApp l op r  -> do+			      l <- checkPat l []+			      r <- checkPat r []+			      case op of+				 HsQConOp c -> return (HsPInfixApp l c r)+				 _ -> patFail ""+	HsTuple es         -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPTuple ps)+	HsList es	   -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPList ps)+	HsParen e	   -> do+			      p <- checkPat e []+			      return (HsPParen p)+	HsAsPat n e	   -> do+			      p <- checkPat e []+			      return (HsPAsPat n p)+	HsWildCard	   -> return HsPWildCard+	HsIrrPat e	   -> do+			      p <- checkPat e []+			      return (HsPIrrPat p)+	HsRecConstr c fs   -> do+			      fs <- mapM checkPatField fs+			      return (HsPRec c fs)+	HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))+	HsRPats s es	   -> do+			      rps <- mapM checkRPattern es+			      return (HsPRPat s rps)+	HsExpTypeSig s e t -> do+			      p <- checkPat e []+			      return (HsPatTypeSig s p t)+	+	-- Hsx+	HsXTag s n attrs mattr cs -> do+			      pattrs <- mapM checkPAttr attrs+			      pcs    <- mapM (\c -> checkPat c []) cs+			      mpattr <- maybe (return Nothing) +			      		  (\e -> do p <- checkPat e []+			      		  	    return $ Just p) +			      		  mattr+			      let cp = mkChildrenPat pcs+			      return $ HsPXTag s n pattrs mpattr cp+	HsXETag s n attrs mattr -> do+			      pattrs <- mapM checkPAttr attrs+			      mpattr <- maybe (return Nothing) +			      		  (\e -> do p <- checkPat e []+			      		  	    return $ Just p) +			      		  mattr+			      return $ HsPXETag s n pattrs mpattr+	HsXPcdata pcdata   -> return $ HsPXPcdata pcdata+	HsXExpTag e	   -> do+			      p <- checkPat e []+			      return $ HsPXPatTag p+	e -> patFail $ show e++checkPat e _ = patFail $ show e++checkPatField :: HsFieldUpdate -> P HsPatField+checkPatField (HsFieldUpdate n e) = do+	p <- checkPat e []+	return (HsPFieldPat n p)++checkPAttr :: HsXAttr -> P HsPXAttr+checkPAttr (HsXAttr n v) = do p <- checkPat v []+			      return $ HsPXAttr n p++patFail :: String -> P a+patFail s = fail $ "Parse error in pattern: " ++ s++checkRPattern :: HsExp -> P HsRPat+checkRPattern e = case e of+	HsSeqRP es	  -> do +			     rps <- mapM checkRPattern es+			     return $ HsRPSeq rps+	HsStarRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPStar rp+	HsPlusRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPPlus rp +	HsOptRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPOpt rp +	HsStarGRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPStarG rp+	HsPlusGRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPPlusG rp +	HsOptGRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPOptG rp +	HsEitherRP e1 e2  -> do+			     rp1 <- checkRPattern e1+			     rp2 <- checkRPattern e2+			     return $ HsRPEither rp1 rp2+	HsCAsRP n e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPCAs n rp+	HsAsPat	n e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPAs n rp+	HsParen e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPParen rp+	_	          -> do+			     p <- checkPattern e+			     return $ HsRPPat p+++mkChildrenPat :: [HsPat] -> HsPat+mkChildrenPat ps = mkCPAux ps []+  where mkCPAux :: [HsPat] -> [HsPat] -> HsPat+  	mkCPAux [] qs = HsPList $ reverse qs+  	mkCPAux (p:ps) qs = case p of+  		(HsPRPat s rps) -> mkCRP s ps (reverse rps ++ map HsRPPat qs)+  		_		-> mkCPAux ps (p:qs)+  		+  	mkCRP :: SrcLoc -> [HsPat] -> [HsRPat] -> HsPat+  	mkCRP s [] rps = HsPRPat s $ reverse rps+  	mkCRP s (p:ps) rps = case p of+  		(HsPRPat _ rqs) -> mkCRP s ps (reverse rqs ++ rps)+  		_ 		-> mkCRP s ps (HsRPPat p : rps)++-----------------------------------------------------------------------------+-- Check Expression Syntax++checkExpr :: HsExp -> P HsExp+checkExpr e = case e of+	HsVar _			  -> return e+	HsIPVar _		  -> return e+	HsCon _			  -> return e+	HsLit _			  -> return e+	HsInfixApp e1 op e2	  -> check2Exprs e1 e2 (flip HsInfixApp op)+	HsApp e1 e2		  -> check2Exprs e1 e2 HsApp+	HsNegApp e		  -> check1Expr e HsNegApp+	HsLambda loc ps e	  -> check1Expr e (HsLambda loc ps)+	HsLet bs e		  -> check1Expr e (HsLet bs)+	HsDLet bs e		  -> check1Expr e (HsDLet bs)+	HsWith e bs		  -> check1Expr e (flip HsWith bs)+	HsIf e1 e2 e3		  -> check3Exprs e1 e2 e3 HsIf+	HsCase e alts		  -> do+				     alts <- mapM checkAlt alts+				     e <- checkExpr e+				     return (HsCase e alts)+	HsDo stmts		  -> do+				     stmts <- mapM checkStmt stmts+				     return (HsDo stmts)+	HsMDo stmts		  -> do+				     stmts <- mapM checkStmt stmts+				     return (HsMDo stmts)+	HsTuple es		  -> checkManyExprs es HsTuple+	HsList es		  -> checkManyExprs es HsList+	HsParen e		  -> check1Expr e HsParen+	HsLeftSection e op	  -> check1Expr e (flip HsLeftSection op)+	HsRightSection op e	  -> check1Expr e (HsRightSection op)+	HsRecConstr c fields	  -> do+				     fields <- mapM checkField fields+				     return (HsRecConstr c fields)+	HsRecUpdate e fields	  -> do+				     fields <- mapM checkField fields+				     e <- checkExpr e+				     return (HsRecUpdate e fields)+	HsEnumFrom e		  -> check1Expr e HsEnumFrom+	HsEnumFromTo e1 e2	  -> check2Exprs e1 e2 HsEnumFromTo+	HsEnumFromThen e1 e2      -> check2Exprs e1 e2 HsEnumFromThen+	HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo+	HsListComp e stmts        -> do+				     stmts <- mapM checkStmt stmts+				     e <- checkExpr e+				     return (HsListComp e stmts)+	HsExpTypeSig loc e ty     -> do+				     e <- checkExpr e+				     return (HsExpTypeSig loc e ty)+	+	--Template Haskell+	HsReifyExp _		  -> return e+	HsBracketExp _		  -> return e+	HsSpliceExp _		  -> return e+	+	-- Hsx+	HsXTag s n attrs mattr cs -> do attrs <- mapM checkAttr attrs+					cs <- mapM checkExpr cs+			     		mattr <- maybe (return Nothing) +			      		  (\e -> checkExpr e >>= return . Just) +			      		  mattr					+					return $ HsXTag s n attrs mattr cs+	HsXETag s n attrs mattr	  -> do attrs <- mapM checkAttr attrs+			     		mattr <- maybe (return Nothing) +			      		  (\e -> checkExpr e >>= return . Just) +			      		  mattr					+					return $ HsXETag s n attrs mattr +	HsXPcdata _		  -> return e+	HsXExpTag e		  -> do e <- checkExpr e+					return $ HsXExpTag e+	-- Functor sugar+	HsFunctorUnit e	          -> do e <- checkExpr e+                                        return $ HsFunctorUnit e+	HsFunctorCall e	          -> do e <- checkExpr e+                                        return $ HsFunctorCall e+	_			  -> fail $ "Parse error in expression: " ++ show e++checkAttr :: HsXAttr -> P HsXAttr+checkAttr (HsXAttr n v) = do v <- checkExpr v+			     return $ HsXAttr n v++-- type signature for polymorphic recursion!!+check1Expr :: HsExp -> (HsExp -> a) -> P a+check1Expr e1 f = do+	e1 <- checkExpr e1+	return (f e1)++check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a+check2Exprs e1 e2 f = do+	e1 <- checkExpr e1+	e2 <- checkExpr e2+	return (f e1 e2)++check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a+check3Exprs e1 e2 e3 f = do+	e1 <- checkExpr e1+	e2 <- checkExpr e2+	e3 <- checkExpr e3+	return (f e1 e2 e3)++checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a+checkManyExprs es f = do+	es <- mapM checkExpr es+	return (f es)++checkAlt :: HsAlt -> P HsAlt+checkAlt (HsAlt loc p galts bs) = do+	galts <- checkGAlts galts+	return (HsAlt loc p galts bs)++checkGAlts :: HsGuardedAlts -> P HsGuardedAlts+checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt+checkGAlts (HsGuardedAlts galts) = do+	galts <- mapM checkGAlt galts+	return (HsGuardedAlts galts)++checkGAlt :: HsGuardedAlt -> P HsGuardedAlt+checkGAlt (HsGuardedAlt loc g e) = check1Expr e (HsGuardedAlt loc g)++checkStmt :: HsStmt -> P HsStmt+checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p)+checkStmt (HsQualifier e) = check1Expr e HsQualifier+checkStmt s@(HsLetStmt _) = return s++checkField :: HsFieldUpdate -> P HsFieldUpdate+checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)++getGConName :: HsExp -> P HsQName+getGConName (HsCon n) = return n+getGConName (HsList []) = return list_cons_name+getGConName _ = fail "Expression in reification is not a name"++-----------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SrcLoc -> HsExp -> HsRhs -> HsBinds -> P HsDecl+checkValDef srcloc lhs rhs whereBinds =+    case isFunLhs lhs [] of+	 Just (f,es) -> do+			ps <- mapM checkPattern es+			return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])+         Nothing     -> do+			lhs <- checkPattern lhs+			return (HsPatBind srcloc lhs rhs whereBinds)++-- A variable binding is parsed as an HsPatBind.++isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp])+isFunLhs (HsInfixApp l (HsQVarOp (UnQual op)) r) es = Just (op, l:r:es)+isFunLhs (HsApp (HsVar (UnQual f)) e) es = Just (f, e:es)+isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)+isFunLhs (HsApp f e) es = isFunLhs f (e:es)+isFunLhs _ _ = Nothing++-----------------------------------------------------------------------------+-- In a class or instance body, a pattern binding must be of a variable.++checkClassBody :: [HsDecl] -> P [HsDecl]+checkClassBody decls = do+	mapM_ checkMethodDef decls+	return decls++checkMethodDef :: HsDecl -> P ()+checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return ()+checkMethodDef (HsPatBind loc _ _ _) =+	fail "illegal method definition" `atSrcLoc` loc+checkMethodDef _ = return ()++-----------------------------------------------------------------------------+-- Check that an identifier or symbol is unqualified.+-- For occasions when doing this in the grammar would cause conflicts.++checkUnQual :: HsQName -> P HsName+checkUnQual (Qual _ _) = fail "Illegal qualified name"+checkUnQual (UnQual n) = return n+checkUnQual (Special _) = fail "Illegal special name"++-----------------------------------------------------------------------------+-- Check that two xml tag names are equal+-- Could use Eq directly, but I am not sure whether <dom:name>...</name> +-- would be valid, in that case Eq won't work. TODO++checkEqNames :: HsXName -> HsXName -> P HsXName+checkEqNames n@(HsXName n1) (HsXName n2) +	| n1 == n2  = return n+	| otherwise = fail "names in matching xml tags are not equal"+checkEqNames n@(HsXDomName d1 n1) (HsXDomName d2 n2)+	| n1 == n2 && d1 == d2 = return n+	| otherwise = fail "names in matching xml tags are not equal"+checkEqNames _ _ = fail "names in matching xml tags are not equal"+++-----------------------------------------------------------------------------+-- Miscellaneous utilities++checkPrec :: Integer -> P Int+checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)+checkPrec i | otherwise	       = fail ("Illegal precedence " ++ show i)++mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp+mkRecConstrOrUpdate (HsCon c) fs       = return (HsRecConstr c fs)+mkRecConstrOrUpdate e         fs@(_:_) = return (HsRecUpdate e fs)+mkRecConstrOrUpdate _         _        = fail "Empty record update"++-----------------------------------------------------------------------------+-- Reverse a list of declarations, merging adjacent HsFunBinds of the+-- same name and checking that their arities match.++checkRevDecls :: [HsDecl] -> P [HsDecl]+checkRevDecls = mergeFunBinds []+    where+	mergeFunBinds revDs [] = return revDs+	mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) =+		mergeMatches ms1 ds1+	    where+		arity = length ps+		mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds)+		    | name' == name =+			if length ps' /= arity+			then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")+			     `atSrcLoc` loc+			else mergeMatches (ms++ms') ds+		mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds+	mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds+++---------------------------------------+-- Converting a complete page++pageFun :: SrcLoc -> HsExp -> HsDecl+pageFun loc e = HsPatBind loc namePat rhs (HsBDecls [])+    where namePat = HsPVar $ HsIdent "page"+    	  rhs = HsUnGuardedRhs e++mkPage :: HsModule -> SrcLoc -> HsExp -> P HsModule+mkPage (HsModule src prags md exps imps decls) loc xml = do+	let page = pageFun loc xml+	return $ HsModule src prags md exps imps (decls ++ [page])+	+mkPageModule :: HsExp -> P HsModule+mkPageModule xml = do +	do loc <- case xml of +	 	   HsXTag l _ _ _ _ -> return l+	 	   HsXETag l _ _ _  -> return l+	 	   _ -> fail "Will not happen since mkPageModule is only called on XML expressions"+	   mod <- getModuleName+	   return $ (HsModule +	  	      loc+	  	      []+	  	      (Module mod)+	  	      (Just [HsEVar $ UnQual $ HsIdent "page"])+	  	      []+	  	      [pageFun loc xml])++---------------------------------------+-- Handle dash-identifiers++mkDVar :: [String] -> String+mkDVar = concat . intersperse "-"++mkDVarExpr :: [String] -> HsExp+mkDVarExpr = foldl1 (\x y -> infixApp x (op $ sym "-") y) . map (var . name)++---------------------------------------+-- Combine adjacent for-alls. +--+-- A valid type must have one for-all at the top of the type, or of the fn arg types++mkHsTyForall :: Maybe [HsName] -> HsContext -> HsType -> HsType+mkHsTyForall mtvs []   ty = mk_forall_ty mtvs ty+mkHsTyForall mtvs ctxt ty = HsTyForall mtvs ctxt ty++-- mk_forall_ty makes a pure for-all type (no context)+mk_forall_ty (Just []) ty 			  = ty	-- Explicit for-all with no tyvars+mk_forall_ty mtvs1     (HsTyForall mtvs2 ctxt ty) = mkHsTyForall (mtvs1 `plus` mtvs2) ctxt ty+mk_forall_ty mtvs1     ty			  = HsTyForall mtvs1 [] ty++mtvs1       `plus` Nothing     = mtvs1+Nothing     `plus` mtvs2       = mtvs2 +(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
+ Preprocessor/Hsx/Parser.ly view
@@ -0,0 +1,1175 @@+> {+> -----------------------------------------------------------------------------+> -- |+> -- Module      :  Preprocessor.Hsx.Parser+> -- Original    :  Language.Haskell.Parser+> -- Copyright   :  (c) Niklas Broberg 2004,+> -- 		    Original (c) Simon Marlow, Sven Panne 1997-2000+> -- License     :  BSD-style (see the file LICENSE.txt)+> --+> -- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+> -- Stability   :  experimental+> -- Portability :  portable+> --+> --+> -----------------------------------------------------------------------------+>+> module Preprocessor.Hsx.Parser (+>		parseModule, parseModuleWithMode,+>		ParseMode(..), defaultParseMode, ParseResult(..)) where+> +> import Preprocessor.Hsx.Syntax+> import Preprocessor.Hsx.ParseMonad+> import Preprocessor.Hsx.Lexer+> import Preprocessor.Hsx.ParseUtils+> }++-----------------------------------------------------------------------------+This module comprises a parser for Haskell 98 with the following extensions++* Multi-parameter type classes with functional dependencies+* Implicit parameters+* Pattern guards+* Mdo notation+* FFI+* HaRP+* HSP++Most of the code is blatantly stolen from the GHC module Preprocessor.Parser.+Some of the code for extensions is greatly influenced by GHC's internal parser+library, ghc/compiler/parser/Parser.y. +-----------------------------------------------------------------------------+Conflicts: 3 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).+	+1 for ambiguity in 'let ?x ...'+	the parser can't tell whether the ?x is the lhs of a normal binding or+	an implicit binding. Fortunately resolving as shift gives it the only+	sensible meaning, namely the lhs of an implicit binding.++-----------------------------------------------------------------------------++> %token+>	VARID 	 { VarId $$ }+>	QVARID 	 { QVarId $$ }+>	IDUPID	 { IDupVarId $$ }	-- duplicable implicit parameter ?x+>	ILINID	 { ILinVarId $$ }	-- linear implicit parameter %x+>	CONID	 { ConId $$ }+>	QCONID   { QConId $$ }+>	DVARID	 { DVarId $$ }		-- VARID containing dashes+>	VARSYM	 { VarSym $$ }+>	CONSYM	 { ConSym $$ }+>	QVARSYM	 { QVarSym $$ }+>	QCONSYM  { QConSym $$ }+>	INT	 { IntTok $$ }+>	RATIONAL { FloatTok $$ }+>	CHAR	 { Character $$ }+>	STRING   { StringTok $$ }+>	PRAGMA   { Pragma $$ }++Symbols++>	'('	{ LeftParen }+>	')'	{ RightParen }+>	'(#'	{ LeftHashParen }+>	'#)'	{ RightHashParen }+>	';'	{ SemiColon }+>	'{'	{ LeftCurly }+>	'}'	{ RightCurly }+>	vccurly { VRightCurly }			-- a virtual close brace+>	'['	{ LeftSquare }+>	']'	{ RightSquare }+>  	','	{ Comma }+>	'_'	{ Underscore }+>	'`'	{ BackQuote }++Reserved operators++>	'.'	{ Dot }+>	'..'	{ DotDot }+>	':'	{ Colon }+>	'::'	{ DoubleColon }+>	'='	{ Equals }+>	'\\'	{ Backslash }+>	'|'	{ Bar }+>	'<-'	{ LeftArrow }+>	'->'	{ RightArrow }+>	'@'	{ At }+>	'~'	{ Tilde }+>	'=>'	{ DoubleArrow }+>	'-'	{ Minus }+>	'!'	{ Exclamation }+>	'#'	{ Hash }++Harp++>	'[/'	{ RPOpen }+>	'/]'	{ RPClose }+>	'(/'	{ RPSeqOpen }+>	'/)'	{ RPSeqClose }+>	'*'	{ RPStar }+>	'*!'	{ RPStarG }+>	'+'	{ RPPlus }+>	'+!'	{ RPPlusG }+>	'?'	{ RPOpt }+>	'?!'	{ RPOptG }+>	'rp|'	{ RPEither } -- '|' already taken+>	'@:'	{ RPCAt }++Template Haskell++>	IDSPLICE 	{ THIdEscape $$ }+>	'$('		{ THParenEscape }+>	'[|'		{ THExpQuote }+>	'[p|'		{ THPatQuote }+>	'[t|'		{ THTypQuote }+>	'[d|'		{ THDecQuote }+>	'|]'		{ THCloseQuote }+>	'reifyDecl'	{ THReifyDecl }+>	'reifyType'	{ THReifyType }+>	'reifyFixity'	{ THReifyFixity }++Hsx++>	PCDATA		{ XPcdata $$ }+>	'<'		{ XStdTagOpen }+>	'</'		{ XCloseTagOpen }+>	'<%'		{ XCodeTagOpen }+>	'>'		{ XStdTagClose }+>	'/>'		{ XEmptyTagClose }+>	'%>'		{ XCodeTagClose }++FFI++>	'foreign'	{ KW_Foreign }+>	'export'	{ KW_Export }+>	'safe'		{ KW_Safe }+>	'unsafe'	{ KW_Unsafe }+>	'threadsafe'	{ KW_Threadsafe }+>	'stdcall'	{ KW_StdCall }+>	'ccall'		{ KW_CCall }++Reserved Ids++>	'as'		{ KW_As }+>	'case'		{ KW_Case }+>	'class'		{ KW_Class }+>	'data'		{ KW_Data }+>	'default'	{ KW_Default }+>	'deriving'	{ KW_Deriving }+>	'dlet'		{ KW_DLet }	-- implicit parameter binding clause+>	'do'		{ KW_Do }+>	'else'		{ KW_Else }+>	'forall'	{ KW_Forall }	-- universal/existential qualification+>	'hiding'	{ KW_Hiding }+>	'if'		{ KW_If }+>	'import'	{ KW_Import }+>	'in'		{ KW_In }+>	'infix'		{ KW_Infix }+>	'infixl'	{ KW_InfixL }+>	'infixr'	{ KW_InfixR }+>	'instance'	{ KW_Instance }+>	'let'		{ KW_Let }+>	'mdo'		{ KW_MDo }+>	'module'	{ KW_Module }+>	'newtype'	{ KW_NewType }+>	'of'		{ KW_Of }+>	'then'		{ KW_Then }+>	'type'		{ KW_Type }+>	'where'		{ KW_Where }+>	'with'		{ KW_With }	-- implicit parameter binding clause+>	'qualified'	{ KW_Qualified }++> %monad { P }+> %lexer { lexer } { EOF }+> %name parse+> %tokentype { Token }+> %%++-----------------------------------------------------------------------------+HSP Pages++> page :: { HsModule }+>	: topxml				{% mkPageModule $1 }+>	| '<%' module '%>' srcloc topxml 	{% mkPage $2 $4 $5 }+>	| module		{ $1 }++> topxml :: { HsExp }+>	: srcloc '<' name attrs mattr '>' children '</' name '>'	{% do { n <- checkEqNames $3 $9;+>										let { cn = reverse $7;+>										      as = reverse $4; };+>										return $ HsXTag $1 n as $5 cn } }+>	| srcloc '<' name attrs mattr '/>'				{ HsXETag $1 $3 (reverse $4) $5 }+++-----------------------------------------------------------------------------+Module Header++> module :: { HsModule }+>	: srcloc pragmas 'module' modid maybeexports 'where' body+>		{ HsModule $1 $2 $4 $5 (fst $7) (snd $7) }+>	| srcloc pragmas body+>		{ HsModule $1 $2 main_mod (Just [HsEVar (UnQual main_name)])+>							(fst $3) (snd $3) }++> pragmas :: { [HsPragma] }+>	: PRAGMA pragmas	{ HsPragma $1 : $2 }+>	| {- empty -}		{ [] }++> 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 '=' ctype+>			{ HsTypeDecl $1 (fst $3) (snd $3) $5 }+>	| srcloc 'data' ctype constrs0 deriving+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsDataDecl $1 cs c t (reverse $4) $5) } }+>	| srcloc 'data' ctype 'where' gadtlist+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsGDataDecl $1 cs c t (reverse $5)) } }+>	| srcloc 'newtype' ctype '=' constr deriving+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsNewTypeDecl $1 cs c t $5 $6) } }++A class declaration may include functional dependencies.+>	| srcloc 'class' ctype fds optcbody+>			{% do { (cs,c,vs) <- checkClassHeader $3;+>				return (HsClassDecl $1 cs c vs $4 $5) } }+>	| srcloc 'instance' ctype optvaldefs+>			{% do { (cs,c,ts) <- checkInstHeader $3;+>				return (HsInstDecl $1 cs c ts $4) } }+>	| srcloc 'default' '(' typelist ')'+>			{ HsDefaultDecl $1 $4 }+>	| srcloc '$(' exp ')'+>                        {% do { e <- checkExpr $3;+>                                return $ HsSpliceDecl $1 $ HsParenSplice e } }+>+>	| srcloc 'foreign' 'import' callconv safety fspec+>			{ let (s,n,t) = $6 in HsForImp $1 $4 $5 s n t }+>	| srcloc 'foreign' 'export' callconv fspec+>			{ let (s,n,t) = $5 in HsForExp $1 $4 s n t }+>       | 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 }++Binding can be either of implicit parameters, or it can be a normal sequence+of declarations. The two kinds cannot be mixed within the same block of+binding.++> binds :: { HsBinds }+>	: decllist			{ HsBDecls $1 }+>	| '{' ipbinds '}'		{ HsIPBinds $2 }+>	| open ipbinds close		{ HsIPBinds $2 }++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] } }++-----------------------------------------------------------------------------+FFI++> callconv :: { HsCallConv }+> 	   : 'stdcall'			{ StdCall }+>	   | 'ccall'			{ CCall }++> safety :: { HsSafety }+>	 : 'safe'			{ PlaySafe False }+>	 | 'unsafe'			{ PlayRisky }+> 	 | 'threadsafe'			{ PlaySafe True }+>	 | {- empty -}			{ PlaySafe False }++> fspec :: { (String, HsName, HsType) }+>	: STRING var_no_safety '::' dtype		{ ($1, $2, $4) }+>	|        var_no_safety '::' dtype		{ ("", $1, $3) }++-----------------------------------------------------------------------------+Types++> dtype :: { HsType }+>	: btype				{ $1 }+>       | btype qtyconop dtype          { HsTyInfix $1 $2 $3 }+>       | btype qtyvarop dtype          { HsTyInfix $1 $2 $3 }+>	| btype '->' dtype		{ HsTyFun $1 $3 }++Implicit parameters can occur in normal types, as well as in contexts.++> type :: { HsType }+>	: ivar '::' dtype		{ HsTyPred $ HsIParam $1 $3 }+>	| dtype				{ $1 }++> btype :: { HsType }+>	: btype atype			{ HsTyApp $1 $2 }+>	| atype				{ $1 }++> atype :: { HsType }+>	: gtycon			{ HsTyCon $1 }+>	| tyvar				{ HsTyVar $1 }+>	| '(' types ')'			{ HsTyTuple Boxed (reverse $2) }+>	| '(#' types1 '#)'		{ HsTyTuple Unboxed (reverse $2) }+>	| '[' type ']'			{ HsTyApp list_tycon $2 }+>	| '(' ctype ')'			{ $2 }++> gtycon :: { HsQName }+>	: qconid			{ $1 }+>	| '(' ')'			{ unit_tycon_name }+>	| '(' '->' ')'			{ fun_tycon_name }+>	| '[' ']'			{ list_tycon_name }+>	| '(' commas ')'		{ tuple_tycon_name $2 }++These are for infix types++> qtyconop :: { HsQName }+>       : qconop                        { $1 }++++++(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 :: { HsType }+>	: 'forall' tyvars '.' ctype	{ mkHsTyForall (Just $2) [] $4 }+>	| context '=>' type		{ mkHsTyForall Nothing $1 $3 }+>	| type				{ $1 }++> context :: { HsContext }+>	: btype				{% checkContext $1 }++> types	:: { [HsType] }+>	: types1 ',' type		{ $3 : $1 }++> types1 :: { [HsType] }+>	: type				{ [$1] }+>	| types1 ',' type		{ $3 : $1 }++> simpletype :: { (HsName, [HsName]) }+>	: tycon tyvars			{ ($1,reverse $2) }++> tyvars :: { [HsName] }+>	: tyvars tyvar			{ $2 : $1 }+>	| {- empty -}			{ [] }++-----------------------------------------------------------------------------+Functional Dependencies++> fds :: { [HsFunDep] }+>	: {- empty -}			{ [] }+>	| '|' fds1			{ reverse $2 }++> fds1 :: { [HsFunDep] }+>	: fds1 ',' fd			{ $3 : $1 }+>	| fd				{ [$1] }++> fd :: { HsFunDep }+>	: tyvars '->' tyvars		{ HsFunDep (reverse $1) (reverse $3) }++-----------------------------------------------------------------------------+Datatype declarations++GADTs++> gadtlist :: { [HsGadtDecl] }+>	: '{' gadtconstrs1 '}'			{ $2 }+>	| open gadtconstrs1 close		{ $2 }++> gadtconstrs1 :: { [HsGadtDecl] }+>	: optsemis gadtconstrs optsemis		{ $2 }++> gadtconstrs :: { [HsGadtDecl] }+>	: gadtconstrs semis gadtconstr		{ $3 : $1 }+>	| gadtconstr 				{ [$1] }++> gadtconstr :: { HsGadtDecl }+>	: srcloc qcon '::' ctype		{% do { c <- checkUnQual $2;+>							return $ HsGadtDecl $1 c $4 } }++> constrs0 :: { [HsQualConDecl] }+>	: {- empty -}			{ [] }+>	| '=' constrs			{ $2 }++> constrs :: { [HsQualConDecl] }+>	: constrs '|' constr		{ $3 : $1 }+>	| constr			{ [$1] }++> constr :: { HsQualConDecl }+>	: srcloc forall context '=>' constr1	{ HsQualConDecl $1 $2 $3 $5 }+>	| srcloc forall constr1			{ HsQualConDecl $1 $2 [] $3 }++> forall :: { [HsName] }+>	: 'forall' tyvars '.'		{ $2 }+>	| {- empty -}			{ [] }++> constr1 :: { HsConDecl }+>	: scontype			{ HsConDecl (fst $1) (snd $1) }+>	| sbtype conop sbtype		{ HsConDecl $2 [$1,$3] }+>	| con '{' '}'			{ HsRecDecl $1 [] }+>	| con '{' fielddecls '}' 	{ HsRecDecl $1 (reverse $3) }++> 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 }+>	: ctype				{ 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++No implicit parameters in the where clause of a class declaration.+> 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 }++May bind implicit parameters+> optwhere :: { HsBinds }+>	: 'where' binds			{ $2 }+>	| {- empty -}			{ HsBDecls [] }++> rhs	:: { HsRhs }+>	: '=' exp			{% do { e <- checkExpr $2;+>						return (HsUnGuardedRhs e) } }+>	| gdrhs				{ HsGuardedRhss  (reverse $1) }++> gdrhs :: { [HsGuardedRhs] }+>	: gdrhs gdrh			{ $2 : $1 }+>	| gdrh				{ [$1] }++Guards may contain patterns, hence quals instead of exp.+> gdrh :: { HsGuardedRhs }+>	: srcloc '|' quals '=' exp	{% do { e <- checkExpr $5;+>						return (HsGuardedRhs $1 (reverse $3) 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 }+>	| exp0b 'with' ipbinding	{ HsWith $1 $3 }  -- implicit parameters+>	| 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 }+>	| dvarexp			{ $1 }+>	| exp10b			{ $1 }++> exp10a :: { HsExp }+>	: '\\' srcloc apats '->' exp	{ HsLambda $2 (reverse $3) $5 }+A let may bind implicit parameters+>  	| 'let' binds 'in' exp		{ HsLet $2 $4 }+>	| 'dlet' ipbinding 'in' exp	{ HsDLet $2 $4 }+>	| 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }++> exp10b :: { HsExp }+>	: 'case' exp 'of' altslist	{ HsCase $2 $4 }+>	| '-' fexp			{ HsNegApp $2 }+>  	| 'do' stmtlist			{ HsDo $2 }+>  	| 'mdo' stmtlist		{ HsMDo $2 }+>	| reifyexp			{ HsReifyExp $1 }+>	| 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) } }+>	| qvar '@:' aexp		{% do { n <- checkUnQual $1;+>						return (HsCAsRP n $3) } }+>	| '~' aexp			{ HsIrrPat $2 }+>	| '#' aexp			{ HsFunctorUnit $2 }+>	| '!' aexp			{ HsFunctorCall $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) }+>	| aexp1 '*'			{ HsStarRP $1 }+>	| aexp1 '*!'			{ HsStarGRP $1 }+>	| aexp1 '+'			{ HsPlusRP $1 }+>	| aexp1 '+!'			{ HsPlusGRP $1 }+>	| aexp1 '?'			{ HsOptRP $1 }+>	| aexp1 '?!'			{ HsOptGRP $1 }+>  	| 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.+An implicit parameter can be used as an expression.++> aexp2	:: { HsExp }+>	: ivar				{ HsIPVar $1 }+>	| 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 }+>	| '(' erpats ')'		{ $2 }+>	| '(/' rpats '/)'		{ HsSeqRP $ reverse $2 }+>	| srcloc '[/' rpats '/]'	{ HsRPats $1 $ reverse $3 }+>	| xml				{ $1 }++Template Haskell+>	| IDSPLICE			{ HsSpliceExp $ HsIdSplice $1 }+>	| '$(' exp ')'			{% do { e <- checkExpr $2;+>						return $ HsSpliceExp $ HsParenSplice e } }+>	| '[|' exp '|]'			{% do { e <- checkExpr $2;+>						return $ HsBracketExp $ HsExpBracket e } }+>	| '[p|' exp0 '|]'		{% do { p <- checkPattern $2;+>						return $ HsBracketExp $ HsPatBracket p } }+>	| '[t|' ctype '|]'		{ HsBracketExp $ HsTypeBracket $2 }+>	| '[d|' topdecls '|]'		{ HsBracketExp $ HsDeclBracket $2 }++> reifyexp :: { HsReify }+>	: 'reifyDecl' gtycon		{ HsReifyDecl $2 }+>	| 'reifyDecl' qvar		{ HsReifyDecl $2 }+>	| 'reifyType' qcname		{ HsReifyType $2 }+>	| 'reifyFixity' qcname		{ HsReifyFixity $2 }++> qcname :: { HsQName }+>	: qvar				{ $1 }+>	| gcon				{% getGConName $1 }+End Template Haskell++> commas :: { Int }+>	: commas ','			{ $1 + 1 }+>	| ','				{ 1 }++> texps :: { [HsExp] }+>	: texps ',' exp			{ $3 : $1 }+>	| exp ',' exp			{ [$3,$1] }++-----------------------------------------------------------------------------+Harp Extensions++> rpats :: { [HsExp] }+>	: rpats ',' rpat		{ $3 : $1 }+>	| rpat				{ [$1] }++> rpat :: { HsExp }+>	: erpats			{ $1 }+>	| exp 				{ $1 }++Either patterns are left associative+> erpats :: { HsExp }+>	: exp 'rp|' erpats		{ HsEitherRP $1 $3 }+>	| exp 'rp|' exp			{ HsEitherRP $1 $3 }++-----------------------------------------------------------------------------+Hsx Extensions++> xml :: { HsExp }+>	: srcloc '<' name attrs mattr '>' children '</' name '>'	{% do { n <- checkEqNames $3 $9;+>										let { cn = reverse $7;+>										      as = reverse $4; };+>										return $ HsXTag $1 n as $5 cn } }+>	| srcloc '<' name attrs mattr '/>'				{ HsXETag $1 $3 (reverse $4) $5 }+>	| '<%' exp '%>'							{ HsXExpTag $2 }++> children :: { [HsExp] }+>	: children child		{ $2 : $1 }+>	| {- empty -}			{ [] }++> child :: { HsExp }+>	: PCDATA			{ HsXPcdata $1 }+>	| srcloc '[/' rpats '/]'	{ HsRPats $1 $ reverse $3 }+>	| xml				{ $1 }++> name :: { HsXName }+>	: xmlname ':' xmlname		{ HsXDomName $1 $3 }+>	| xmlname			{ HsXName $1 }++> xmlname :: { String }+>	: VARID				{ $1 }+>	| CONID				{ $1 }+>	| DVARID			{ mkDVar $1 }+>	| 'type'			{ "type" }+>	| 'class'			{ "class" }++> attrs :: { [HsXAttr] }+>	: attrs attr			{ $2 : $1 }+>	| {- empty -}			{ [] }++> attr :: { HsXAttr }+>	: name '=' aexp			{ HsXAttr $1 $3 }++> mattr :: { Maybe HsExp }+>	: aexp				{ Just $1 }+>	| {-empty-}			{ Nothing }++Turning dash variables into infix expressions with '-'+> dvarexp :: { HsExp }+>	  : DVARID			{ mkDVarExpr $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' binds			{ 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] }++A guard can be a pattern guard, hence quals instead of exp0.+> gdpat	:: { HsGuardedAlt }+>	: srcloc '|' quals '->' exp	{ HsGuardedAlt $1 (reverse $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 }++A let statement may bind implicit parameters.+> stmts :: { [HsStmt] }+>	: 'let' binds ';' 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 }++-----------------------------------------------------------------------------+Implicit parameter bindings++> ipbinding :: { [HsIPBind] }+>	: '{' ipbinds '}'		{ $2 }+>	| open ipbinds close		{ $2 }++> ipbinds :: { [HsIPBind] }+> 	: optsemis ipbinds1 optsemis	{ reverse $2 }++> ipbinds1 :: { [HsIPBind] }+>	: ipbinds1 semis ipbind		{ $3 : $1 }+>	| ipbind			{ [$1] }++> ipbind :: { HsIPBind }+>	: srcloc ivar '=' exp		{ HsIPBind $1 $2 $4 }++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++> gcon :: { HsExp }+>  	: '(' ')'		{ unit_con }+>	| '[' ']'		{ HsList [] }+>	| '(' commas ')'	{ tuple_con $2 }+>  	| qcon			{ HsCon $1 }++> var 	:: { HsName }+>	: varid			{ $1 }+>	| '(' varsym ')'	{ $2 }++> var_no_safety :: { HsName }+>		: varid_no_safety	{ $1 }+>		| '(' varsym ')'	{ $2 }++> qvar 	:: { HsQName }+>	: qvarid		{ $1 }+>	| '(' qvarsym ')'	{ $2 }++Implicit parameter+> ivar 	:: { HsIPName }+>	: ivarid		{ $1 }++> 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_no_safety :: { HsName }+>	: VARID			{ HsIdent $1 }+>	| 'as'			{ as_name }+>	| 'qualified'		{ qualified_name }+>	| 'hiding'		{ hiding_name }+>	| 'export'		{ export_name }+>	| 'stdcall'		{ stdcall_name }+>	| 'ccall'		{ ccall_name }++> varid :: { HsName }+>	: varid_no_safety	{ $1 }+>	| 'safe'		{ safe_name }+>	| 'unsafe'		{ unsafe_name }+>	| 'threadsafe'		{ threadsafe_name }+++Implicit parameter+> ivarid :: { HsIPName }+>	: IDUPID		{ HsIPDup $1 }+>	| ILINID		{ HsIPLin $1 }++> 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 }+>	| '-'			{ minus_name }+>	| '!'			{ pling_name }+>	| '.'			{ dot_name }++> varsymm :: { HsName } -- varsym not including '-'+>	: VARSYM		{ HsSymbol $1 }+>	| '!'			{ pling_name }+>	| '.'			{ dot_name }++> 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 }++> qtyvarop :: { HsQName }+> qtyvarop : '`' tyvar '`'       { UnQual $2 }+>          | tyvarsym            { UnQual $1 }++> tyvarsym :: { HsName }+> tyvarsym : VARSYM              { HsSymbol $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+> }
+ Preprocessor/Hsx/Pretty.hs view
@@ -0,0 +1,986 @@+{-# OPTIONS_GHC -w #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Pretty+-- Original    :  Language.Haskell.Pretty+-- Copyright   :  (c) Niklas Broberg 2004,+-- 		  (c) The GHC Team, Noel Winstanley 1997-2000+-- License     :  BSD-style (see the file LICENSE.txt)+--+-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Pretty printer for Haskell with extensions.+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Pretty (+		-- * Pretty printing+		Pretty,+		prettyPrintStyleMode, prettyPrintWithMode, prettyPrint,+		-- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")+		P.Style(..), P.style, P.Mode(..),+		-- * Haskell formatting modes+		PPHsMode(..), Indent, PPLayout(..), defaultMode) where++import Preprocessor.Hsx.Syntax++import qualified Text.PrettyPrint as P++infixl 5 $$$++-----------------------------------------------------------------------------++-- | Varieties of layout we can use.+data PPLayout = PPOffsideRule	-- ^ classical layout+	      | PPSemiColon	-- ^ classical layout made explicit+	      | PPInLine	-- ^ inline decls, with newlines between them+	      | PPNoLayout	-- ^ everything on a single line+	      deriving Eq++type Indent = Int++-- | Pretty-printing parameters.+--+-- /Note:/ the 'onsideIndent' must be positive and less than all other indents.+data PPHsMode = PPHsMode {+				-- | indentation of a class or instance+		classIndent :: Indent,+				-- | indentation of a @do@-expression+		doIndent :: Indent,+				-- | indentation of the body of a+				-- @case@ expression+		caseIndent :: Indent,+				-- | indentation of the declarations in a+				-- @let@ expression+		letIndent :: Indent,+				-- | indentation of the declarations in a+				-- @where@ clause+		whereIndent :: Indent,+				-- | indentation added for continuation+				-- lines that would otherwise be offside+		onsideIndent :: Indent,+				-- | blank lines between statements?+		spacing :: Bool,+				-- | Pretty-printing style to use+		layout :: PPLayout,+				-- | add GHC-style @LINE@ pragmas to output?+		linePragmas :: Bool,+				-- | not implemented yet+		comments :: Bool+		}++-- | The default mode: pretty-print using the offside rule and sensible+-- defaults.+defaultMode :: PPHsMode+defaultMode = PPHsMode{+		      classIndent = 8,+		      doIndent = 3,+		      caseIndent = 4,+		      letIndent = 4,+		      whereIndent = 6,+		      onsideIndent = 2,+		      spacing = True,+		      layout = PPOffsideRule,+		      linePragmas = False,+		      comments = True+		      }++-- | Pretty printing monad+newtype DocM s a = DocM (s -> a)++instance Functor (DocM s) where+	 fmap f xs = do x <- xs; return (f x)++instance Monad (DocM s) where+	(>>=) = thenDocM+	(>>) = then_DocM+	return = retDocM++{-# INLINE thenDocM #-}+{-# INLINE then_DocM #-}+{-# INLINE retDocM #-}+{-# INLINE unDocM #-}+{-# INLINE getPPEnv #-}++thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b+thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)++then_DocM :: DocM s a -> DocM s b -> DocM s b+then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s)++retDocM :: a -> DocM s a+retDocM a = DocM (\_s -> a)++unDocM :: DocM s a -> (s -> a)+unDocM (DocM f) = f++-- all this extra stuff, just for this one function.+getPPEnv :: DocM s s+getPPEnv = DocM id++-- So that pp code still looks the same+-- this means we lose some generality though++-- | The document type produced by these pretty printers uses a 'PPHsMode'+-- environment.+type Doc = DocM PPHsMode P.Doc++-- | Things that can be pretty-printed, including all the syntactic objects+-- in "Preprocessor.Syntax".+class Pretty a where+	-- | Pretty-print something in isolation.+	pretty :: a -> Doc+	-- | Pretty-print something in a precedence context.+	prettyPrec :: Int -> a -> Doc+	pretty = prettyPrec 0+	prettyPrec _ = pretty++-- The pretty printing combinators++empty :: Doc+empty = return P.empty++nest :: Int -> Doc -> Doc+nest i m = m >>= return . P.nest i+++-- Literals++text, ptext :: String -> Doc+text = return . P.text+ptext = return . P.text++char :: Char -> Doc+char = return . P.char++int :: Int -> Doc+int = return . P.int++integer :: Integer -> Doc+integer = return . P.integer++float :: Float -> Doc+float = return . P.float++double :: Double -> Doc+double = return . P.double++rational :: Rational -> Doc+rational = return . P.rational++-- Simple Combining Forms++parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc+parens d = d >>= return . P.parens+brackets d = d >>= return . P.brackets+braces d = d >>= return . P.braces+quotes d = d >>= return . P.quotes+doubleQuotes d = d >>= return . P.doubleQuotes++parensIf :: Bool -> Doc -> Doc+parensIf True = parens+parensIf False = id++-- Constants++semi,comma,colon,space,equals :: Doc+semi = return P.semi+comma = return P.comma+colon = return P.colon+space = return P.space+equals = return P.equals++lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc+lparen = return  P.lparen+rparen = return  P.rparen+lbrack = return  P.lbrack+rbrack = return  P.rbrack+lbrace = return  P.lbrace+rbrace = return  P.rbrace++-- Combinators++(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc+aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}+aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}+aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}+aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}++hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc+hcat dl = sequence dl >>= return . P.hcat+hsep dl = sequence dl >>= return . P.hsep+vcat dl = sequence dl >>= return . P.vcat+sep dl = sequence dl >>= return . P.sep+cat dl = sequence dl >>= return . P.cat+fsep dl = sequence dl >>= return . P.fsep+fcat dl = sequence dl >>= return . P.fcat++-- Some More++hang :: Doc -> Int -> Doc -> Doc+hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}++-- Yuk, had to cut-n-paste this one from Pretty.hs+punctuate :: Doc -> [Doc] -> [Doc]+punctuate _ []     = []+punctuate p (d1:ds) = go d1 ds+                   where+                     go d [] = [d]+                     go d (e:es) = (d <> p) : go e es++-- | render the document with a given style and mode.+renderStyleMode :: P.Style -> PPHsMode -> Doc -> String+renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode++-- | render the document with a given mode.+renderWithMode :: PPHsMode -> Doc -> String+renderWithMode = renderStyleMode P.style++-- | render the document with 'defaultMode'.+render :: Doc -> String+render = renderWithMode defaultMode++-- | pretty-print with a given style and mode.+prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String+prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty++-- | pretty-print with the default style and a given mode.+prettyPrintWithMode :: Pretty a => PPHsMode -> a -> String+prettyPrintWithMode = prettyPrintStyleMode P.style++-- | pretty-print with the default style and 'defaultMode'.+prettyPrint :: Pretty a => a -> String+prettyPrint = prettyPrintWithMode defaultMode++fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->+		      (P.TextDetails -> a -> a) -> a -> Doc -> a+fullRenderWithMode ppMode m i f fn e mD =+		   P.fullRender m i f fn e $ (unDocM mD) ppMode+++fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)+	      -> a -> Doc -> a+fullRender = fullRenderWithMode defaultMode++-------------------------  Pretty-Print a Module --------------------+instance Pretty HsModule where+	pretty (HsModule pos prags m mbExports imp decls) =+		markLine pos $+		topLevel (ppHsModuleHeader prags m mbExports)+			 (map pretty imp ++ map pretty decls)++--------------------------  Module Header ------------------------------+ppHsModuleHeader :: [HsPragma] -> Module -> Maybe [HsExportSpec] ->  Doc+ppHsModuleHeader prags m mbExportList = mySep $ prags' ++ [+	text "module",+	pretty m,+	maybePP (parenList . map pretty) mbExportList,+	text "where"]+    where prags' = map (\(HsPragma s) -> text $ "{-#" ++ s ++ "#-}") prags++instance Pretty Module where+	pretty (Module modName) = text modName++instance Pretty HsExportSpec where+	pretty (HsEVar name)		    = pretty name+	pretty (HsEAbs name)		    = pretty name+	pretty (HsEThingAll name)	    = pretty name <> text "(..)"+	pretty (HsEThingWith name nameList) =+		pretty name <> (parenList . map pretty $ nameList)+	pretty (HsEModuleContents m)        = text "module" <+> pretty m++instance Pretty HsImportDecl where+	pretty (HsImportDecl pos m qual mbName mbSpecs) =+		markLine pos $+		mySep [text "import",+		       if qual then text "qualified" else empty,+		       pretty m,+		       maybePP (\m' -> text "as" <+> pretty m') mbName,+		       maybePP exports mbSpecs]+	    where+		exports (b,specList) =+			if b then text "hiding" <+> specs else specs+		    where specs = parenList . map pretty $ specList++instance Pretty HsImportSpec where+	pretty (HsIVar name)                = pretty name+	pretty (HsIAbs name)                = pretty name+	pretty (HsIThingAll name)           = pretty name <> text "(..)"+	pretty (HsIThingWith name nameList) =+		pretty name <> (parenList . map pretty $ nameList)++-------------------------  Declarations ------------------------------+instance Pretty HsDecl where+	pretty (HsTypeDecl loc name nameList htype) =+		blankline $+		markLine loc $+		mySep ( [text "type", pretty name]+			++ map pretty nameList+			++ [equals, pretty htype])++	pretty (HsDataDecl loc context name nameList constrList derives) =+		blankline $+		markLine loc $+		mySep ( [text "data", ppHsContext context, pretty name]+			++ map pretty nameList)+			<+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+						   (map pretty constrList))+			$$$ ppHsDeriving derives)++	pretty (HsGDataDecl loc context name nameList gadtList) =+		blankline $+		markLine loc $+		mySep ( [text "data", ppHsContext context, pretty name]+			++ map pretty nameList ++ [text "where"])+			$$$ ppBody classIndent (map pretty gadtList)++	pretty (HsNewTypeDecl pos context name nameList constr derives) =+		blankline $+		markLine pos $+		mySep ( [text "newtype", ppHsContext context, pretty name]+			++ map pretty nameList)+			<+> equals <+> (pretty constr $$$ ppHsDeriving derives)++	--m{spacing=False}+	-- special case for empty class declaration+	pretty (HsClassDecl pos context name nameList fundeps []) =+		blankline $+		markLine pos $+		mySep ( [text "class", ppHsContext context, pretty name]+			++ map pretty nameList ++ [ppFunDeps fundeps])+	pretty (HsClassDecl pos context name nameList fundeps declList) =+		blankline $+		markLine pos $+		mySep ( [text "class", ppHsContext context, pretty name]+			++ map pretty nameList ++ [ppFunDeps fundeps, text "where"])+		$$$ ppBody classIndent (map pretty declList)++	-- m{spacing=False}+	-- special case for empty instance declaration+	pretty (HsInstDecl pos context name args []) =+		blankline $+		markLine pos $+		mySep ( [text "instance", ppHsContext context, pretty name]+			++ map ppHsAType args)+	pretty (HsInstDecl pos context name args declList) =+		blankline $+		markLine pos $+		mySep ( [text "instance", ppHsContext context, pretty name]+			++ map ppHsAType args ++ [text "where"])+		$$$ ppBody classIndent (map pretty declList)++	pretty (HsDefaultDecl pos htypes) =+		blankline $+		markLine pos $+		text "default" <+> parenList (map pretty htypes)++        pretty (HsSpliceDecl pos splice) =+		blankline $+		markLine pos $+                pretty splice++	pretty (HsTypeSig pos nameList qualType) =+		blankline $+		markLine pos $+		mySep ((punctuate comma . map pretty $ nameList)+		      ++ [text "::", pretty qualType])++	pretty (HsFunBind matches) =+		foldr ($$$) empty (map pretty matches)++	pretty (HsPatBind pos pat rhs whereBinds) =+		markLine pos $+		myFsep [pretty pat, pretty rhs] $$$ ppWhere whereBinds++	pretty (HsInfixDecl pos assoc prec opList) =+		blankline $+		markLine pos $+		mySep ([pretty assoc, int prec]+		       ++ (punctuate comma . map pretty $ opList))++	pretty (HsForImp pos cconv saf str name typ) =+		blankline $+		markLine pos $+		mySep [text "foreign import", pretty cconv, pretty saf, +                       text (show str), pretty name, text "::", pretty typ]++	pretty (HsForExp pos cconv str name typ) =+		blankline $+		markLine pos $+		mySep [text "foreign export", pretty cconv,+                       text (show str), pretty name, text "::", pretty typ]++instance Pretty HsAssoc where+	pretty HsAssocNone  = text "infix"+	pretty HsAssocLeft  = text "infixl"+	pretty HsAssocRight = text "infixr"++instance Pretty HsMatch where+	pretty (HsMatch pos f ps rhs whereBinds) =+		markLine pos $+		myFsep (lhs ++ [pretty rhs])+		$$$ ppWhere whereBinds+	    where+		lhs = case ps of+			l:r:ps' | isSymbolName f ->+				let hd = [pretty l, ppHsName f, pretty r] in+				if null ps' then hd+				else parens (myFsep hd) : map (prettyPrec 2) ps'+			_ -> pretty f : map (prettyPrec 2) ps++ppWhere :: HsBinds -> Doc+ppWhere (HsBDecls []) = empty+ppWhere (HsBDecls l)  = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l))+ppWhere (HsIPBinds b) = nest 2 (text "where" $$$ ppBody whereIndent (map pretty b))++------------------------- FFI stuff -------------------------------------+instance Pretty HsSafety where+	pretty PlayRisky	= text "unsafe"+	pretty (PlaySafe b)	= text $ if b then "threadsafe" else "safe"++instance Pretty HsCallConv where+ 	pretty StdCall 	= text "stdcall"+	pretty CCall	= text "ccall"++------------------------- Data & Newtype Bodies -------------------------+instance Pretty HsQualConDecl where+	pretty (HsQualConDecl _pos tvs ctxt con) =+		myFsep [ppForall (Just tvs), ppHsContext ctxt, pretty con]++instance Pretty HsGadtDecl where+	pretty (HsGadtDecl _pos name ty) =+		myFsep [pretty name, text "::", pretty ty]++instance Pretty HsConDecl where+	pretty (HsRecDecl name fieldList) =+		pretty name <> (braceList . map ppField $ fieldList)++	pretty (HsConDecl name@(HsSymbol _) [l, r]) =+		myFsep [prettyPrec prec_btype l, ppHsName name, +			prettyPrec prec_btype r]+	pretty (HsConDecl name typeList) =+		mySep $ ppHsName name : map (prettyPrec prec_atype) typeList++ppField :: ([HsName],HsBangType) -> Doc+ppField (names, ty) =+	myFsepSimple $ (punctuate comma . map pretty $ names) +++		       [text "::", pretty ty]++instance Pretty HsBangType where+	prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty+	prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty++ppHsDeriving :: [HsQName] -> Doc+ppHsDeriving []  = empty+ppHsDeriving [d] = text "deriving" <+> ppHsQName d+ppHsDeriving ds  = text "deriving" <+> parenList (map ppHsQName ds)++------------------------- Types -------------------------+{-+instance Pretty HsQualType where+	pretty (HsQualType context htype) =+		myFsep [ppHsContext context, pretty htype]+-}+ppHsBType :: HsType -> Doc+ppHsBType = prettyPrec prec_btype++ppHsAType :: HsType -> Doc+ppHsAType = prettyPrec prec_atype++-- precedences for types+prec_btype, prec_atype :: Int+prec_btype = 1	-- left argument of ->,+		-- or either argument of an infix data constructor+prec_atype = 2	-- argument of type or data constructor, or of a class++instance Pretty HsType where+	prettyPrec p (HsTyForall mtvs ctxt htype) = parensIf (p > 0) $+		myFsep [ppForall mtvs, ppHsContext ctxt, pretty htype]+	prettyPrec p (HsTyFun a b) = parensIf (p > 0) $+		myFsep [ppHsBType a, text "->", pretty b]+	prettyPrec _ (HsTyTuple bxd l) = +		let ds = map pretty l+		 in case bxd of +			Boxed   -> parenList ds+			Unboxed -> hashParenList ds+	prettyPrec p (HsTyApp a b)+		| a == list_tycon = brackets $ pretty b		-- special case+		| otherwise = parensIf (p > prec_btype) $+			myFsep [pretty a, ppHsAType b]+	prettyPrec _ (HsTyVar name) = pretty name+	prettyPrec _ (HsTyCon name) = pretty name+	prettyPrec _ (HsTyPred asst) = pretty asst+        prettyPrec _ (HsTyInfix a op b) = parens (myFsep [pretty op, parens (pretty a), parens (pretty b)])+++ppForall :: Maybe [HsName] -> Doc+ppForall Nothing   = empty+ppForall (Just []) = empty+ppForall (Just vs) = 	myFsep (text "forall" : map pretty vs ++ [char '.'])++------------------- Functional Dependencies -------------------+instance Pretty HsFunDep where+	pretty (HsFunDep from to) = +		myFsep $ map pretty from ++ [text "->"] ++ map pretty to+++ppFunDeps :: [HsFunDep] -> Doc+ppFunDeps [] = empty+ppFunDeps fds = myFsep $ (char '|':) . punctuate comma . map pretty $ fds++------------------------- Expressions -------------------------+instance Pretty HsRhs where+	pretty (HsUnGuardedRhs e) = equals <+> pretty e+	pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList++instance Pretty HsGuardedRhs where+	pretty (HsGuardedRhs _pos guards ppBody) =+		myFsep $ [char '|'] ++ (punctuate comma . map pretty $ guards) ++ [equals, pretty ppBody]++instance Pretty HsLiteral where+	pretty (HsInt i)        = integer i+	pretty (HsChar c)       = text (show c)+	pretty (HsString s)     = text (show s)+	pretty (HsFrac r)       = double (fromRational r)+	-- GHC unboxed literals:+	pretty (HsCharPrim c)   = text (show c)           <> char '#'+	pretty (HsStringPrim s) = text (show s)           <> char '#'+	pretty (HsIntPrim i)    = integer i               <> char '#'+	pretty (HsFloatPrim r)  = float  (fromRational r) <> char '#'+	pretty (HsDoublePrim r) = double (fromRational r) <> text "##"++instance Pretty HsExp where+	pretty (HsLit l) = pretty l+	-- lambda stuff+	pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b]+	pretty (HsNegApp e) = myFsep [char '-', pretty e]+	pretty (HsApp a b) = myFsep [pretty a, pretty b]+	pretty (HsLambda _loc expList ppBody) = myFsep $+		char '\\' : map pretty expList ++ [text "->", pretty ppBody]+	-- keywords+	-- two cases for lets+	pretty (HsLet (HsBDecls declList) letBody) =+		ppLetExp declList letBody+	pretty (HsLet (HsIPBinds bindList) letBody) =+		ppLetExp bindList letBody+	pretty (HsDLet bindList letBody) =+		myFsep [text "dlet" <+> ppBody letIndent (map pretty bindList),+			text "in", pretty letBody]+	pretty (HsWith exp bindList) =+		pretty exp $$$ ppWith bindList+	pretty (HsIf cond thenexp elsexp) =+		myFsep [text "if", pretty cond,+			text "then", pretty thenexp,+			text "else", pretty elsexp]+	pretty (HsCase cond altList) =+		myFsep [text "case", pretty cond, text "of"]+		$$$ ppBody caseIndent (map pretty altList)+	pretty (HsDo stmtList) =+		text "do" $$$ ppBody doIndent (map pretty stmtList)+	pretty (HsMDo stmtList) =+		text "mdo" $$$ ppBody doIndent (map pretty stmtList)+	-- Constructors & Vars+	pretty (HsVar name) = pretty name+	pretty (HsIPVar ipname) = pretty ipname+	pretty (HsCon name) = pretty name+	pretty (HsTuple expList) = parenList . map pretty $ expList+	-- weird stuff+	pretty (HsParen e) = parens . pretty $ e+	pretty (HsLeftSection e op) = parens (pretty e <+> pretty op)+	pretty (HsRightSection op e) = parens (pretty op <+> pretty e)+	pretty (HsRecConstr c fieldList) =+		pretty c <> (braceList . map pretty $ fieldList)+	pretty (HsRecUpdate e fieldList) =+		pretty e <> (braceList . map pretty $ fieldList)+	-- patterns+	-- special case that would otherwise be buggy+	pretty (HsAsPat name (HsIrrPat e)) =+		myFsep [pretty name <> char '@', char '~' <> pretty e]+	pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e]+	pretty HsWildCard = char '_'+	pretty (HsIrrPat e) = char '~' <> pretty e+	-- Lists+	pretty (HsList list) =+		bracketList . punctuate comma . map pretty $ list+	pretty (HsEnumFrom e) =+		bracketList [pretty e, text ".."]+	pretty (HsEnumFromTo from to) =+		bracketList [pretty from, text "..", pretty to]+	pretty (HsEnumFromThen from thenE) =+		bracketList [pretty from <> comma, pretty thenE, text ".."]+	pretty (HsEnumFromThenTo from thenE to) =+		bracketList [pretty from <> comma, pretty thenE,+			     text "..", pretty to]+	pretty (HsListComp e stmtList) =+		bracketList ([pretty e, char '|']+			     ++ (punctuate comma . map pretty $ stmtList))+	pretty (HsExpTypeSig _pos e ty) =+		myFsep [pretty e, text "::", pretty ty]+	-- Template Haskell+	pretty (HsReifyExp r) = pretty r+	pretty (HsBracketExp b) = pretty b+	pretty (HsSpliceExp s) = pretty s+	-- regular patterns+	pretty (HsRPats _ rs) = +		myFsep $ text "[/" : map pretty rs ++ [text "/]"]+	pretty (HsSeqRP rs) =+		myFsep $ text "(/" : map pretty rs ++ [text "/)"]+	pretty (HsStarRP r) = pretty r <> char '*'+	pretty (HsStarGRP r) = pretty r <> text "*!"+	pretty (HsPlusRP r) = pretty r <> char '+'+	pretty (HsPlusGRP r) = pretty r <> text "+!"+	pretty (HsOptRP r) = pretty r <> char '?'+	pretty (HsOptGRP r) = pretty r <> text "?!"+	pretty (HsEitherRP r1 r2) = parens . myFsep $ +		[pretty r1, char '|', pretty r2]+	-- special case that would otherwise be buggy+	pretty (HsCAsRP n (HsIrrPat e)) =+		myFsep [pretty n <> text "@:", char '~' <> pretty e]+	pretty (HsCAsRP n r) = hcat [pretty n, text "@:", pretty r]+	-- Hsx+	pretty (HsXTag _ n attrs mattr cs) =+		let ax = maybe [] (return . pretty) mattr+		 in hcat $ +		     (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):+		 	map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]+	pretty (HsXETag _ n attrs mattr) =+		let ax = maybe [] (return . pretty) mattr+		 in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [text "/>"]+	pretty (HsXPcdata s) = text s+	pretty (HsXExpTag e) = +		myFsep $ [text "<%", pretty e, text "%>"]++instance Pretty HsXAttr where+	pretty (HsXAttr n v) =+		myFsep [pretty n, char '=', pretty v]++instance Pretty HsXName where+	pretty (HsXName n) = text n+	pretty (HsXDomName d n) = text d <> char ':' <> text n++--ppLetExp :: [HsDecl] -> HsExp -> Doc+ppLetExp l b = myFsep [text "let" <+> ppBody letIndent (map pretty l),+			text "in", pretty b]++ppWith binds = nest 2 (text "with" $$$ ppBody withIndent (map pretty binds))+withIndent = whereIndent++--------------------- Template Haskell -------------------------+instance Pretty HsReify where+	pretty (HsReifyDecl name) = ppReify "reifyDecl" name+	pretty (HsReifyType name) = ppReify "reifyType" name+	pretty (HsReifyFixity name) = ppReify "reifyFixity" name++ppReify t n = myFsep [text t, pretty n]++instance Pretty HsBracket where+	pretty (HsExpBracket e) = ppBracket "[|" e+	pretty (HsPatBracket p) = ppBracket "[p|" p+	pretty (HsTypeBracket t) = ppBracket "[t|" t+	pretty (HsDeclBracket d) =+		myFsep $ text "[d|" : map pretty d ++ [text "|]"]++ppBracket o x = myFsep [text o, pretty x, text "|]"]++instance Pretty HsSplice where+	pretty (HsIdSplice s) = char '$' <> text s+	pretty (HsParenSplice e) =+		myFsep [text "$(", pretty e, char ')']++------------------------- Patterns -----------------------------++instance Pretty HsPat where+	prettyPrec _ (HsPVar name) = pretty name+	prettyPrec _ (HsPLit lit) = pretty lit+	prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p]+	prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $+		myFsep [pretty a, pretty (HsQConOp op), pretty b]+	prettyPrec p (HsPApp n ps) = parensIf (p > 1) $+		myFsep (pretty n : map pretty ps)+	prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps+	prettyPrec _ (HsPList ps) =+		bracketList . punctuate comma . map pretty $ ps+	prettyPrec _ (HsPParen p) = parens . pretty $ p+	prettyPrec _ (HsPRec c fields) =+		pretty c <> (braceList . map pretty $ fields)+	-- special case that would otherwise be buggy+	prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) =+		myFsep [pretty name <> char '@', char '~' <> pretty pat]+	prettyPrec _ (HsPAsPat name pat) =+		hcat [pretty name, char '@', pretty pat]+	prettyPrec _ HsPWildCard = char '_'+	prettyPrec _ (HsPIrrPat pat) = char '~' <> pretty pat+	prettyPrec _ (HsPRPat _ rs) = +		myFsep $ text "[/" : map pretty rs ++ [text "/]"]+	prettyPrec _ (HsPatTypeSig _pos pat ty) =+		myFsep [pretty pat, text "::", pretty ty]++	-- Hsx+	prettyPrec _ (HsPXTag _ n attrs mattr cp) =+		let ap = maybe [] (return . pretty) mattr+		 in hcat $ -- TODO: should not introduce blanks+		      (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [char '>']):+			prettyChildren cp ++ [myFsep $ [text "</" <> pretty n, char '>']]+	prettyPrec _ (HsPXETag _ n attrs mattr) =+		let ap = maybe [] (return . pretty) mattr+		 in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [text "/>"]+	prettyPrec _ (HsPXPcdata s) = text s+	prettyPrec _ (HsPXPatTag p) = +		myFsep $ [text "<%", pretty p, text "%>"]++prettyChildren :: HsPat -> [Doc]+prettyChildren p = case p of+	HsPList ps  -> map prettyChild ps+	HsPRPat _ _ -> [pretty p]+	_ 	    -> error "The pattern representing the children of an xml pattern\+				\ should always be a list."++prettyChild :: HsPat -> Doc+prettyChild p = case p of+	HsPXTag _ _ _ _ _ -> pretty p+	HsPXETag _ _ _ _  -> pretty p+	HsPXPatTag _  	  -> pretty p+	HsPXPcdata _  	  -> pretty p+	_	      	  -> pretty $ HsPXPatTag p++instance Pretty HsPXAttr where+	pretty (HsPXAttr n p) = +		myFsep [pretty n, char '=', pretty p]++instance Pretty HsPatField where+	pretty (HsPFieldPat name pat) =+		myFsep [pretty name, equals, pretty pat]++--------------------- Regular Patterns -------------------------++instance Pretty HsRPat where+	pretty (HsRPStar r) = pretty r <> char '*'+	pretty (HsRPStarG r) = pretty r <> text "*!"+	pretty (HsRPPlus r) = pretty r <> char '+'+	pretty (HsRPPlusG r) = pretty r <> text "+!"+	pretty (HsRPOpt r) = pretty r <> char '?'+	pretty (HsRPOptG r) = pretty r <> text "?!"+	pretty (HsRPEither r1 r2) = parens . myFsep $ +		[pretty r1, char '|', pretty r2]+	pretty (HsRPSeq rs) =+		myFsep $ text "(/" : map pretty rs ++ [text "/)"]+	-- special case that would otherwise be buggy+	pretty (HsRPCAs n (HsRPPat (HsPIrrPat p))) =+		myFsep [pretty n <> text "@:", char '~' <> pretty p]+	pretty (HsRPCAs n r) = hcat [pretty n, text "@:", pretty r]+	-- special case that would otherwise be buggy+	pretty (HsRPAs n (HsRPPat (HsPIrrPat p))) =+		myFsep [pretty n <> text "@:", char '~' <> pretty p]+	pretty (HsRPAs n r) = hcat [pretty n, char '@', pretty r]+	pretty (HsRPPat p) = pretty p+	pretty (HsRPParen rp) = parens . pretty $ rp++------------------------- Case bodies  -------------------------+instance Pretty HsAlt where+	pretty (HsAlt _pos e gAlts binds) =+		pretty e <+> pretty gAlts $$$ ppWhere binds++instance Pretty HsGuardedAlts where+	pretty (HsUnGuardedAlt e) = text "->" <+> pretty e+	pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList++instance Pretty HsGuardedAlt where+	pretty (HsGuardedAlt _pos guards body) =+		myFsep $ char '|': (punctuate comma . map pretty $ guards) ++ [text "->", pretty body]++------------------------- Statements in monads, guards & list comprehensions -----+instance Pretty HsStmt where+	pretty (HsGenerator _loc e from) =+		pretty e <+> text "<-" <+> pretty from+	pretty (HsQualifier e) = pretty e+	-- two cases for lets+	pretty (HsLetStmt (HsBDecls declList)) =+		ppLetStmt declList+	pretty (HsLetStmt (HsIPBinds bindList)) =+		ppLetStmt bindList++ppLetStmt l = text "let" $$$ ppBody letIndent (map pretty l)+	+------------------------- Record updates+instance Pretty HsFieldUpdate where+	pretty (HsFieldUpdate name e) =+		myFsep [pretty name, equals, pretty e]++------------------------- Names -------------------------+instance Pretty HsQOp where+	pretty (HsQVarOp n) = ppHsQNameInfix n+	pretty (HsQConOp n) = ppHsQNameInfix n++ppHsQNameInfix :: HsQName -> Doc+ppHsQNameInfix name+	| isSymbolName (getName name) = ppHsQName name+	| otherwise = char '`' <> ppHsQName name <> char '`'++instance Pretty HsQName where+	pretty name = case name of+		UnQual (HsSymbol ('#':_)) -> char '(' <+> ppHsQName name <+> char ')'+		_ -> parensIf (isSymbolName (getName name)) (ppHsQName name)++ppHsQName :: HsQName -> Doc+ppHsQName (UnQual name) = ppHsName name+ppHsQName (Qual m name) = pretty m <> char '.' <> ppHsName name+ppHsQName (Special sym) = text (specialName sym)++instance Pretty HsOp where+	pretty (HsVarOp n) = ppHsNameInfix n+	pretty (HsConOp n) = ppHsNameInfix n++ppHsNameInfix :: HsName -> Doc+ppHsNameInfix name+	| isSymbolName name = ppHsName name+	| otherwise = char '`' <> ppHsName name <> char '`'++instance Pretty HsName where+	pretty name = case name of+		HsSymbol ('#':_) -> char '(' <+> ppHsName name <+> char ')'+		_ -> parensIf (isSymbolName name) (ppHsName name)++ppHsName :: HsName -> Doc+ppHsName (HsIdent s) = text s+ppHsName (HsSymbol s) = text s++instance Pretty HsIPName where+	pretty (HsIPDup s) = char '?' <> text s+	pretty (HsIPLin s) = char '%' <> text s+	+instance Pretty HsIPBind where+	pretty (HsIPBind _loc ipname exp) =+		myFsep [pretty ipname, equals, pretty exp]++instance Pretty HsCName where+	pretty (HsVarName n) = pretty n+	pretty (HsConName n) = pretty n++isSymbolName :: HsName -> Bool+isSymbolName (HsSymbol _) = True+isSymbolName _ = False++getName :: HsQName -> HsName+getName (UnQual s) = s+getName (Qual _ s) = s+getName (Special HsCons) = HsSymbol ":"+getName (Special HsFunCon) = HsSymbol "->"+getName (Special s) = HsIdent (specialName s)++specialName :: HsSpecialCon -> String+specialName HsUnitCon = "()"+specialName HsListCon = "[]"+specialName HsFunCon = "->"+specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")"+specialName HsCons = ":"++ppHsContext :: HsContext -> Doc+ppHsContext []      = empty+ppHsContext context = mySep [parenList (map pretty context), text "=>"]++-- hacked for multi-parameter type classes+instance Pretty HsAsst where+	pretty (HsClassA a ts) = myFsep $ ppHsQName a : map ppHsAType ts+	pretty (HsIParam i t)  = myFsep $ [pretty i, text "::", pretty t]++------------------------- pp utils -------------------------+maybePP :: (a -> Doc) -> Maybe a -> Doc+maybePP pp Nothing = empty+maybePP pp (Just a) = pp a++parenList :: [Doc] -> Doc+parenList = parens . myFsepSimple . punctuate comma++hashParenList :: [Doc] -> Doc+hashParenList = hashParens . myFsepSimple . punctuate comma +  where hashParens = parens . hashes+  	hashes = \doc -> char '#' <> doc <> char '#'++braceList :: [Doc] -> Doc+braceList = braces . myFsepSimple . punctuate comma++bracketList :: [Doc] -> Doc+bracketList = brackets . myFsepSimple++-- Wrap in braces and semicolons, with an extra space at the start in+-- case the first doc begins with "-", which would be scanned as {-+flatBlock :: [Doc] -> Doc+flatBlock = braces . (space <>) . hsep . punctuate semi++-- Same, but put each thing on a separate line+prettyBlock :: [Doc] -> Doc+prettyBlock = braces . (space <>) . vcat . punctuate semi++-- Monadic PP Combinators -- these examine the env++blankline :: Doc -> Doc+blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout+			      then space $$ dl else dl}+topLevel :: Doc -> [Doc] -> Doc+topLevel header dl = do+	 e <- fmap layout getPPEnv+	 case e of+	     PPOffsideRule -> header $$ vcat dl+	     PPSemiColon -> header $$ prettyBlock dl+	     PPInLine -> header $$ prettyBlock dl+	     PPNoLayout -> header <+> flatBlock dl++ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc+ppBody f dl = do+	 e <- fmap layout getPPEnv+	 case e of PPOffsideRule -> indent+		   PPSemiColon   -> indentExplicit+		   _ -> flatBlock dl+		   where+		   indent  = do{i <-fmap f getPPEnv;nest i . vcat $ dl}+		   indentExplicit = do {i <- fmap f getPPEnv;+			   nest i . prettyBlock $ dl}++($$$) :: Doc -> Doc -> Doc+a $$$ b = layoutChoice (a $$) (a <+>) b++mySep :: [Doc] -> Doc+mySep = layoutChoice mySep' hsep+	where+	-- ensure paragraph fills with indentation.+	mySep' [x]    = x+	mySep' (x:xs) = x <+> fsep xs+	mySep' []     = error "Internal error: mySep"++myVcat :: [Doc] -> Doc+myVcat = layoutChoice vcat hsep++myFsepSimple :: [Doc] -> Doc+myFsepSimple = layoutChoice fsep hsep++-- same, except that continuation lines are indented,+-- which is necessary to avoid triggering the offside rule.+myFsep :: [Doc] -> Doc+myFsep = layoutChoice fsep' hsep+	where	fsep' [] = empty+		fsep' (d:ds) = do+			e <- getPPEnv+			let n = onsideIndent e+			nest n (fsep (nest (-n) d:ds))++layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc+layoutChoice a b dl = do e <- getPPEnv+                         if layout e == PPOffsideRule ||+                            layout e == PPSemiColon+                          then a dl else b dl++-- Prefix something with a LINE pragma, if requested.+-- GHC's LINE pragma actually sets the current line number to n-1, so+-- that the following line is line n.  But if there's no newline before+-- the line we're talking about, we need to compensate by adding 1.++markLine :: SrcLoc -> Doc -> Doc+markLine loc doc = do+	e <- getPPEnv+	let y = srcLine loc+	let line l =+	      text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}")+	if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc+	      else doc
+ Preprocessor/Hsx/Syntax.hs view
@@ -0,0 +1,806 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Syntax+-- Original    :  Language.Haskell.Syntax+-- Copyright   :  (c) Niklas Broberg 2004,+--                (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- A suite of datatypes describing the abstract syntax of Haskell 98+-- <http://www.haskell.org/onlinereport/> plus some extensions:+--+--   * multi-parameter type classes with functional dependencies+--+--   * parameters of type class assertions are unrestricted+--+--   * 'forall' types as universal and existential quantification+--+--   * pattern guards+--+--   * implicit parameters+--+--   * generalised algebraic data types+--+--   * template haskell+--+--   * empty data type declarations+--+--   * unboxed tuples+--+--   * regular patterns (HaRP)+--+--   * HSP-style XML expressions and patterns (HSP)+--+-- Also worth noting is that (n+k) patterns from Haskell 98 are not supported+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Syntax (+    -- * Modules+    HsModule(..), HsPragma(..), HsExportSpec(..),+    HsImportDecl(..), HsImportSpec(..), HsAssoc(..),+    -- * Declarations+    HsDecl(..), HsBinds(..), HsIPBind(..), +    HsGadtDecl(..), HsConDecl(..), HsQualConDecl(..), HsBangType(..),+    HsMatch(..), HsRhs(..), HsGuardedRhs(..),+    -- * Class Assertions and Contexts+    HsContext, HsFunDep(..), HsAsst(..),+    -- * Types+    HsType(..), HsBoxed(..),+    -- * Expressions+    HsExp(..), HsStmt(..), HsFieldUpdate(..),+    HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..), +    -- * Patterns+    HsPat(..), HsPatField(..),+    -- * Literals+    HsLiteral(..),+    -- * Variables, Constructors and Operators+    Module(..), HsQName(..), HsName(..), HsQOp(..), HsOp(..),+    HsSpecialCon(..), HsCName(..), HsIPName(..),+    +    -- * Template Haskell+    HsReify(..), HsBracket(..), HsSplice(..),+    +    -- * HaRP+    HsRPat(..),+    +    -- * Hsx+    HsXAttr(..), HsXName(..), HsPXAttr(..),++    -- * FFI+    HsSafety(..), HsCallConv(..),++    -- * Builtin names++    -- ** Modules+    prelude_mod, main_mod,+    -- ** Main function of a program+    main_name,+    -- ** Constructors+    unit_con_name, tuple_con_name, list_cons_name,+    unit_con, tuple_con,+    -- ** Special identifiers+    as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name,+    export_name, safe_name, unsafe_name, threadsafe_name, stdcall_name, ccall_name,+    -- ** Type constructors+    unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name,+    unit_tycon, fun_tycon, list_tycon, tuple_tycon,++    -- * Source coordinates+    SrcLoc(..),+  ) where+++#ifdef __GLASGOW_HASKELL__+import Data.Generics.Basics+import Data.Generics.Instances+#endif++-- | A position in the source.+data SrcLoc = SrcLoc {+		srcFilename :: String,+		srcLine :: Int,+		srcColumn :: Int+		}+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif+  +-- | The name of a Haskell module.+newtype Module = Module String+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | Constructors with special syntax.+-- These names are never qualified, and always refer to builtin type or+-- data constructors.++data HsSpecialCon+	= HsUnitCon		-- ^ unit type and data constructor @()@+	| HsListCon		-- ^ list type constructor @[]@+	| HsFunCon		-- ^ function type constructor @->@+	| HsTupleCon Int	-- ^ /n/-ary tuple type and data+				--   constructors @(,)@ etc+	| HsCons		-- ^ list data constructor @(:)@+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | This type is used to represent qualified variables, and also+-- qualified constructors.+data HsQName+	= Qual Module HsName	-- ^ name qualified with a module name+	| UnQual HsName		-- ^ unqualified name+	| Special HsSpecialCon	-- ^ built-in constructor with special syntax+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | This type is used to represent variables, and also constructors.+data HsName+	= HsIdent String	-- ^ /varid/ or /conid/.+	| HsSymbol String	-- ^ /varsym/ or /consym/+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | This type is used to represent implicit parameter names.+data HsIPName+	= HsIPDup String -- ?x+	| HsIPLin String -- %x+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | Possibly qualified infix operators (/qop/), appearing in expressions.+data HsQOp+	= HsQVarOp HsQName	-- ^ variable operator (/qvarop/)+	| HsQConOp HsQName	-- ^ constructor operator (/qconop/)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | Operators, appearing in @infix@ declarations.+data HsOp+	= HsVarOp HsName	-- ^ variable operator (/varop/)+	| HsConOp HsName	-- ^ constructor operator (/conop/)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | A name (/cname/) of a component of a class or data type in an @import@+-- or export specification.+data HsCName+	= HsVarName HsName	-- ^ name of a method or field+	| HsConName HsName	-- ^ name of a data constructor+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | A Haskell source module.+data HsModule = HsModule SrcLoc [HsPragma] Module (Maybe [HsExportSpec])+                         [HsImportDecl] [HsDecl]+#ifdef __GLASGOW_HASKELL__+  deriving (Show,Typeable,Data)+#else+  deriving (Show)+#endif++-- | A pragma at the beginning of a module.+data HsPragma = HsPragma String+#ifdef __GLASGOW_HASKELL__+  deriving (Show,Typeable,Data)+#else+  deriving (Show)+#endif++-- | Export specification.+data HsExportSpec+	 = HsEVar HsQName			-- ^ variable+	 | HsEAbs HsQName			-- ^ @T@:+			-- a class or datatype exported abstractly,+			-- or a type synonym.+	 | HsEThingAll HsQName			-- ^ @T(..)@:+			-- a class exported with all of its methods, or+			-- a datatype exported with all of its constructors.+	 | HsEThingWith HsQName [HsCName]	-- ^ @T(C_1,...,C_n)@:+			-- a class exported with some of its methods, or+			-- a datatype exported with some of its constructors.+	 | HsEModuleContents Module		-- ^ @module M@:+			-- re-export a module.+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Import declaration.+data HsImportDecl = HsImportDecl+	{ importLoc :: SrcLoc		-- ^ position of the @import@ keyword.+	, importModule :: Module	-- ^ name of the module imported.+	, importQualified :: Bool	-- ^ imported @qualified@?+	, importAs :: Maybe Module	-- ^ optional alias name in an+					-- @as@ clause.+	, importSpecs :: Maybe (Bool,[HsImportSpec])+			-- ^ optional list of import specifications.+			-- The 'Bool' is 'True' if the names are excluded+			-- by @hiding@.+	}+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Import specification.+data HsImportSpec+	 = HsIVar HsName			-- ^ variable+	 | HsIAbs HsName			-- ^ @T@:+			-- the name of a class, datatype or type synonym.+	 | HsIThingAll HsName			-- ^ @T(..)@:+			-- a class imported with all of its methods, or+			-- a datatype imported with all of its constructors.+	 | HsIThingWith HsName [HsCName]	-- ^ @T(C_1,...,C_n)@:+			-- a class imported with some of its methods, or+			-- a datatype imported with some of its constructors.+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Associativity of an operator.+data HsAssoc+	 = HsAssocNone	-- ^ non-associative operator (declared with @infix@)+	 | HsAssocLeft	-- ^ left-associative operator (declared with @infixl@).+	 | HsAssocRight	-- ^ right-associative operator (declared with @infixr@)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsDecl+	 = HsTypeDecl	 SrcLoc HsName [HsName] HsType+	 | HsDataDecl	 SrcLoc HsContext HsName [HsName] [HsQualConDecl] [HsQName]+	 | HsGDataDecl 	 SrcLoc HsContext HsName [HsName] [HsGadtDecl] {-no deriving-}+	 | HsInfixDecl   SrcLoc HsAssoc Int [HsOp]+	 | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsQualConDecl [HsQName]+	 | HsClassDecl	 SrcLoc HsContext HsName [HsName] [HsFunDep] [HsDecl]+	 | HsInstDecl	 SrcLoc HsContext HsQName [HsType] [HsDecl]+	 | HsDefaultDecl SrcLoc [HsType]+         | HsSpliceDecl  SrcLoc HsSplice+	 | HsTypeSig	 SrcLoc [HsName] HsType+	 | HsFunBind     [HsMatch]+	 | HsPatBind	 SrcLoc HsPat HsRhs {-where-} HsBinds+	 | HsForImp	 SrcLoc HsCallConv HsSafety String HsName HsType+	 | HsForExp	 SrcLoc HsCallConv          String HsName HsType+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsBinds+	= HsBDecls [HsDecl]+	| HsIPBinds [HsIPBind]+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsIPBind = HsIPBind SrcLoc HsIPName HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Clauses of a function binding.+data HsMatch+	 = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} HsBinds+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsQualConDecl+	= HsQualConDecl SrcLoc +	    {-forall-} [HsName] {- . -} HsContext+		{- => -} HsConDecl+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsGadtDecl +	= HsGadtDecl SrcLoc HsName HsType+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Declaration of a data constructor.+data HsConDecl+	 = HsConDecl HsName [HsBangType]+				-- ^ ordinary data constructor+	 | HsRecDecl HsName [([HsName],HsBangType)]+				-- ^ record constructor+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | The type of a constructor argument or field, optionally including+-- a strictness annotation.+data HsBangType+	 = HsBangedTy   HsType	-- ^ strict component, marked with \"@!@\"+	 | HsUnBangedTy HsType	-- ^ non-strict component+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | The right hand side of a function or pattern binding.+data HsRhs+	 = HsUnGuardedRhs HsExp	-- ^ unguarded right hand side (/exp/)+	 | HsGuardedRhss  [HsGuardedRhs]+				-- ^ guarded right hand side (/gdrhs/)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+-- | A guarded right hand side @|@ /exp/ @=@ /exp/.+-- The first expression will be Boolean-valued.+data HsGuardedRhs+	 = HsGuardedRhs SrcLoc [HsStmt] HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | A type qualified with a context.+--   An unqualified type has an empty context.++data HsType+	 = HsTyForall +	 	(Maybe [HsName])+	 	HsContext+	 	HsType+	 | HsTyFun   HsType HsType	-- ^ function type+	 | HsTyTuple HsBoxed [HsType]	-- ^ tuple type, possibly boxed+	 | HsTyApp   HsType HsType	-- ^ application of a type constructor+	 | HsTyVar   HsName		-- ^ type variable+	 | HsTyCon   HsQName		-- ^ named type or type constructor+	 | HsTyPred  HsAsst 		-- ^ assertion of an implicit parameter+	 | HsTyInfix HsType HsQName HsType -- ^ infix type constructor+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsBoxed = Boxed | Unboxed+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+++-- | A functional dependency, given on the form+--   l1 l2 ... ln -> r2 r3 .. rn+data HsFunDep+	= HsFunDep [HsName] [HsName]+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+++type HsContext = [HsAsst]++-- | Class assertions.+--   In Haskell 98, the argument would be a /tyvar/, but this definition+--   allows multiple parameters, and allows them to be /type/s.+--   Also extended with support for implicit parameters.+data HsAsst    	= HsClassA HsQName [HsType]+		| HsIParam HsIPName HsType+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | /literal/+-- Values of this type hold the abstract value of the literal, not the+-- precise string representation used.  For example, @10@, @0o12@ and @0xa@+-- have the same representation.+data HsLiteral+	= HsChar	Char		-- ^ character literal+	| HsString	String		-- ^ string literal+	| HsInt		Integer		-- ^ integer literal+	| HsFrac	Rational	-- ^ floating point literal+	| HsCharPrim	Char		-- ^ GHC unboxed character literal+	| HsStringPrim	String		-- ^ GHC unboxed string literal+	| HsIntPrim	Integer		-- ^ GHC unboxed integer literal+	| HsFloatPrim	Rational	-- ^ GHC unboxed float literal+	| HsDoublePrim	Rational	-- ^ GHC unboxed double literal+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Haskell expressions.+--+-- /Notes:/+--+-- * Because it is difficult for parsers to distinguish patterns from+--   expressions, they typically parse them in the same way and then check+--   that they have the appropriate form.  Hence the expression type+--   includes some forms that are found only in patterns.  After these+--   checks, these constructors should not be used.+--+-- * The parser does not take precedence and associativity into account,+--   so it will leave 'HsInfixApp's associated to the left.+--+-- * The 'Preprocessor.Pretty.Pretty' instance for 'HsExp' does not+--   add parentheses in printing.++data HsExp+	= HsVar HsQName			-- ^ variable+	| HsIPVar HsIPName		-- ^ implicit parameter variable+	| HsCon HsQName			-- ^ data constructor+	| HsLit HsLiteral		-- ^ literal constant+	| HsInfixApp HsExp HsQOp HsExp	-- ^ infix application+	| HsApp HsExp HsExp		-- ^ ordinary application+	| HsNegApp HsExp		-- ^ negation expression @-@ /exp/+	| HsLambda SrcLoc [HsPat] HsExp -- ^ lambda expression+	| HsLet HsBinds HsExp		-- ^ local declarations with @let@+	| HsDLet [HsIPBind] HsExp	-- ^ local declarations of implicit parameters (hugs)+	| HsWith HsExp [HsIPBind]	-- ^ local declarations of implicit parameters+	| HsIf HsExp HsExp HsExp	-- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/+	| HsCase HsExp [HsAlt]		-- ^ @case@ /exp/ @of@ /alts/+	| HsDo [HsStmt]			-- ^ @do@-expression:+					-- the last statement in the list+					-- should be an expression.+	| HsMDo [HsStmt]		-- ^ @mdo@-expression+	| HsTuple [HsExp]		-- ^ tuple expression+	| HsList [HsExp]		-- ^ list expression+	| HsParen HsExp			-- ^ parenthesized expression+	| HsLeftSection HsExp HsQOp	-- ^ left section @(@/exp/ /qop/@)@+	| HsRightSection HsQOp HsExp	-- ^ right section @(@/qop/ /exp/@)@+	| HsRecConstr HsQName [HsFieldUpdate]+					-- ^ record construction expression+	| HsRecUpdate HsExp [HsFieldUpdate]+					-- ^ record update expression+	| HsEnumFrom HsExp		-- ^ unbounded arithmetic sequence,+					-- incrementing by 1+	| HsEnumFromTo HsExp HsExp	-- ^ bounded arithmetic sequence,+					-- incrementing by 1+	| HsEnumFromThen HsExp HsExp	-- ^ unbounded arithmetic sequence,+					-- with first two elements given+	| HsEnumFromThenTo HsExp HsExp HsExp+					-- ^ bounded arithmetic sequence,+					-- with first two elements given+	| HsListComp HsExp [HsStmt]	-- ^ list comprehension+	| HsExpTypeSig SrcLoc HsExp HsType+					-- ^ expression type signature+	| HsAsPat HsName HsExp		-- ^ patterns only+	| HsWildCard			-- ^ patterns only+	| HsIrrPat HsExp		-- ^ patterns only++-- HaRP+	| HsRPats SrcLoc [HsExp]	-- ^ regular patterns only+	| HsSeqRP [HsExp]		-- ^ regular patterns only+	| HsStarRP HsExp		-- ^ regular patterns only+	| HsStarGRP HsExp		-- ^ regular patterns only+	| HsPlusRP HsExp		-- ^ regular patterns only+	| HsPlusGRP HsExp		-- ^ regular patterns only+	| HsOptRP HsExp			-- ^ regular patterns only+	| HsOptGRP HsExp		-- ^ regular patterns only+	| HsEitherRP HsExp HsExp	-- ^ regular patterns only+	| HsCAsRP HsName HsExp		-- ^ regular patterns only+	+-- Template Haskell+	| HsReifyExp HsReify+	| HsBracketExp HsBracket+	| HsSpliceExp HsSplice+	+-- Hsx+	| HsXTag SrcLoc HsXName [HsXAttr] (Maybe HsExp) [HsExp]+	| HsXETag SrcLoc HsXName [HsXAttr] (Maybe HsExp)+	| HsXPcdata String+	| HsXExpTag HsExp++-- Functor sugar+        | HsFunctorUnit HsExp+        | HsFunctorCall HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsXName +	= HsXName String		-- <name ...+	| HsXDomName String String	-- <dom:name ...+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsXAttr = HsXAttr HsXName HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsReify +	= HsReifyType HsQName+	| HsReifyDecl HsQName+	| HsReifyFixity HsQName+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+ +data HsBracket+	= HsExpBracket HsExp+	| HsPatBracket HsPat+	| HsTypeBracket HsType+	| HsDeclBracket [HsDecl]+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsSplice+	= HsIdSplice String+	| HsParenSplice HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+++-- FFI stuff+data HsSafety+	= PlayRisky+	| PlaySafe Bool+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsCallConv+	= StdCall+	| CCall+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++++-- | A pattern, to be matched against a value.+data HsPat+	= HsPVar HsName			-- ^ variable+	| HsPLit HsLiteral		-- ^ literal constant+	| HsPNeg HsPat			-- ^ negated pattern+	| HsPInfixApp HsPat HsQName HsPat+					-- ^ pattern with infix data constructor+	| HsPApp HsQName [HsPat]	-- ^ data constructor and argument+					-- patterns+	| HsPTuple [HsPat]		-- ^ tuple pattern+	| HsPList [HsPat]		-- ^ list pattern+	| HsPParen HsPat		-- ^ parenthesized pattern+	| HsPRec HsQName [HsPatField]	-- ^ labelled pattern+	| HsPAsPat HsName HsPat		-- ^ @\@@-pattern+	| HsPWildCard			-- ^ wildcard pattern (@_@)+	| HsPIrrPat HsPat		-- ^ irrefutable pattern (@~@)+	| HsPatTypeSig SrcLoc HsPat HsType+					-- ^ pattern type signature+	+-- HaRP+	| HsPRPat SrcLoc [HsRPat]	-- ^ regular pattern (HaRP)+-- Hsx+	| HsPXTag SrcLoc HsXName [HsPXAttr] (Maybe HsPat) HsPat+					-- ^ XML tag pattern+	| HsPXETag SrcLoc HsXName [HsPXAttr] (Maybe HsPat)+					-- ^ XML singleton tag pattern+	| HsPXPcdata String+					-- ^ XML PCDATA pattern+	| HsPXPatTag HsPat+					-- ^ XML embedded pattern+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An XML attribute in an XML tag pattern	+data HsPXAttr = HsPXAttr HsXName HsPat+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An entity in a regular pattern (HaRP)+data HsRPat+	= HsRPStar HsRPat+	| HsRPStarG HsRPat+	| HsRPPlus HsRPat+	| HsRPPlusG HsRPat+	| HsRPOpt HsRPat+	| HsRPOptG HsRPat+	| HsRPEither HsRPat HsRPat+	| HsRPSeq [HsRPat]+	| HsRPCAs HsName HsRPat+	| HsRPAs HsName HsRPat+	| HsRPParen HsRPat+	| HsRPPat HsPat+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An /fpat/ in a labeled record pattern.+data HsPatField+	= HsPFieldPat HsQName HsPat+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | This type represents both /stmt/ in a @do@-expression,+--   and /qual/ in a list comprehension, as well as /stmt/+--   in a pattern guard.+data HsStmt+	= HsGenerator SrcLoc HsPat HsExp+				-- ^ a generator /pat/ @<-@ /exp/+	| HsQualifier HsExp	-- ^ an /exp/ by itself: in a @do@-expression,+				-- an action whose result is discarded;+				-- in a list comprehension, a guard expression+	| HsLetStmt HsBinds	-- ^ local bindings+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An /fbind/ in a labeled construction or update.+data HsFieldUpdate+	= HsFieldUpdate HsQName HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An /alt/ in a @case@ expression.+data HsAlt+	= HsAlt SrcLoc HsPat HsGuardedAlts HsBinds+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsGuardedAlts+	= HsUnGuardedAlt HsExp		-- ^ @->@ /exp/+	| HsGuardedAlts  [HsGuardedAlt]	-- ^ /gdpat/+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | A guarded alternative @|@ /stmt/, ... , /stmt/ @->@ /exp/.+data HsGuardedAlt+	= HsGuardedAlt SrcLoc [HsStmt] HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-----------------------------------------------------------------------------+-- Builtin names.++prelude_mod, main_mod :: Module+prelude_mod	      = Module "Prelude"+main_mod	      = Module "Main"++main_name :: HsName+main_name	      = HsIdent "main"++unit_con_name :: HsQName+unit_con_name	      = Special HsUnitCon++tuple_con_name :: Int -> HsQName+tuple_con_name i      = Special (HsTupleCon (i+1))++list_cons_name :: HsQName+list_cons_name	      = Special HsCons++unit_con :: HsExp+unit_con	      = HsCon unit_con_name++tuple_con :: Int -> HsExp+tuple_con i	      = HsCon (tuple_con_name i)++as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name :: HsName+as_name	              = HsIdent "as"+qualified_name        = HsIdent "qualified"+hiding_name	      = HsIdent "hiding"+minus_name	      = HsSymbol "-"+pling_name	      = HsSymbol "!"+dot_name	      = HsSymbol "."++export_name, safe_name, unsafe_name, threadsafe_name, stdcall_name, ccall_name :: HsName+export_name		= HsIdent "export"+safe_name		= HsIdent "safe"+unsafe_name		= HsIdent "unsafe"+threadsafe_name		= HsIdent "threadsafe"+stdcall_name		= HsIdent "stdcall"+ccall_name		= HsIdent "ccall"++unit_tycon_name, fun_tycon_name, list_tycon_name :: HsQName+unit_tycon_name       = unit_con_name+fun_tycon_name        = Special HsFunCon+list_tycon_name       = Special HsListCon++tuple_tycon_name :: Int -> HsQName+tuple_tycon_name i    = tuple_con_name i++unit_tycon, fun_tycon, list_tycon :: HsType+unit_tycon	      = HsTyCon unit_tycon_name+fun_tycon	      = HsTyCon fun_tycon_name+list_tycon	      = HsTyCon list_tycon_name++tuple_tycon :: Int -> HsType+tuple_tycon i	      = HsTyCon (tuple_tycon_name i)
+ Preprocessor/Hsx/Transform.hs view
@@ -0,0 +1,1797 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Harp.Tranform+-- Copyright   :  (c) Niklas Broberg 2004,+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Functions for transforming abstract Haskell code extended with regular +-- patterns into semantically equivalent normal abstract Haskell code. In+-- other words, we transform away regular patterns.+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Transform (+	transform		-- :: HsModule -> HsModule+	) where++import Preprocessor.Hsx.Syntax+import Preprocessor.Hsx.Build+import Data.List (union)++import Debug.Trace (trace)++-----------------------------------------------------------------------------+-- A monad for threading a boolean value through the boilerplate code,+-- to signal whether a transformation has taken place or not.++newtype HsxM a = MkHsxM (HsxState -> (a, HsxState))++instance Monad HsxM where+ return x = MkHsxM (\s -> (x,s))+ (MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s+				      (MkHsxM f') = k a+				   in f' s')++getHsxState :: HsxM HsxState+getHsxState = MkHsxM (\s -> (s, s))++setHsxState :: HsxState -> HsxM ()+setHsxState s = MkHsxM (\_ -> ((),s))++instance Functor HsxM where+ fmap f hma = do a <- hma+		 return $ f a++-----++type HsxState = (Bool, Bool)++initHsxState :: HsxState+initHsxState = (False, False)++setHarpTransformed :: HsxM ()+setHarpTransformed = +	do (_,x) <- getHsxState+	   setHsxState (True,x)++setXmlTransformed :: HsxM ()+setXmlTransformed =+	do (h,_) <- getHsxState+	   setHsxState (h,True)++runHsxM :: HsxM a -> (a, (Bool, Bool))+runHsxM (MkHsxM f) = f initHsxState++-----------------------------------------------------------------------------+-- Traversing and transforming the syntax tree+++-- | Transform away occurences of regular patterns from an abstract+-- Haskell module, preserving semantics.+transform :: HsModule -> HsModule+transform (HsModule s prags m mes is decls) =+	let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls+	    -- We may need to add an import for Match.hs that defines the matcher monad+	    imps1 = if harp +		     then (:) $ HsImportDecl s match_mod True+			  	 (Just match_qual_mod)+			  	 Nothing+		     else id+	    imps2 = {- if hsx+	    	     then (:) $ HsImportDecl s hsx_data_mod False+	    	     		 Nothing+	    	     		 Nothing+	    	     else -} id		-- we no longer want to import HSP.Data+            imps3 = if True --functor+                     then (:) $ HsImportDecl s functor_qual_mod True+                                 Nothing+                                 Nothing+                     else id+            prags' = HsPragma " OPTIONS_GHC -fth " : prags+	 in HsModule s prags' m mes (imps1 $ imps2 $ imps3 is) decls'++-----------------------------------------------------------------------------+-- Declarations++-- | Transform a declaration by transforming subterms that could+-- contain regular patterns.+transformDecl :: HsDecl -> HsxM HsDecl+transformDecl d = case d of+	-- Pattern binds can contain regular patterns in the pattern being bound+	-- as well as on the right-hand side and in declarations in a where clause+	HsPatBind srcloc pat rhs decls -> do+	  	-- Preserve semantics of irrefutable regular patterns by postponing+	  	-- their evaluation to a let-expression on the right-hand side+	  	let ([pat'], rnpss) = unzip $ renameIrrPats [pat]+	  	-- Transform the pattern itself+		([pat''], attrGuards, guards, decls'') <- transformPatterns [pat']+		-- Transform the right-hand side, and add any generated guards+		-- and let expressions to it+		rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs +		-- Transform declarations in the where clause, adding any generated+		-- declarations to it+		decls' <- case decls of+			   HsBDecls ds -> do ds' <- transformLetDecls ds+					     return $ HsBDecls $ decls'' ++ ds'+			   _           -> error "Cannot bind implicit parameters in the \+					    \ \'where\' clause of a function using regular patterns."+		return $ HsPatBind srcloc pat'' rhs' decls'++	-- Function binds can contain regular patterns in their matches+	HsFunBind ms -> fmap HsFunBind $ mapM transformMatch ms+	-- Instance declarations can contain regular patterns in the+	-- declarations of functions inside it+	HsInstDecl s c n ts decls ->+		fmap (HsInstDecl s c n ts) $ mapM transformDecl decls+	-- Class declarations can contain regular patterns in the+	-- declarations of automatically instantiated functions+	HsClassDecl s c n ns ds decls ->+		fmap (HsClassDecl s c n ns ds) $ mapM transformDecl decls+	-- Type signatures, type, newtype or data declarations, infix declarations+	-- and default declarations; none can contain regular patterns+	_ -> return d+	++-- | Transform a function "match" by generating pattern guards and+-- declarations representing regular patterns in the argument list.+-- Subterms, such as guards and the right-hand side, are also traversed+-- transformed.+transformMatch :: HsMatch -> HsxM HsMatch+transformMatch (HsMatch srcloc name pats rhs decls) = do+	-- Preserve semantics of irrefutable regular patterns by postponing+	-- their evaluation to a let-expression on the right-hand side+  	let (pats', rnpss) = unzip $ renameIrrPats pats+  	-- Transform the patterns that stand as arguments to the function+  	(pats'', attrGuards, guards, decls'') <- transformPatterns pats'+	-- Transform the right-hand side, and add any generated guards+	-- and let expressions to it+  	rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs+	-- Transform declarations in the where clause, adding any generated+	-- declarations to it+  	decls' <- case decls of+  		   HsBDecls ds -> do ds' <- transformLetDecls ds+			  	     return $ HsBDecls $ decls'' ++ ds'+  		   _           -> error "Cannot bind implicit parameters in the \+  		  		     \ \'where\' clause of a function using regular patterns."++	return $ HsMatch srcloc name pats'' rhs' decls'+-- | Transform and update guards and right-hand side of a function or+-- pattern binding. The supplied list of guards is prepended to the +-- original guards, and subterms are traversed and transformed.+mkRhs :: SrcLoc -> [Guard] -> [(HsName, HsPat)] -> HsRhs -> HsxM HsRhs+mkRhs srcloc guards rnps (HsUnGuardedRhs rhs) = do+	-- Add the postponed patterns to the right-hand side by placing+	-- them in a let-expression to make them lazily evaluated.+	-- Then transform the whole right-hand side as an expression.+	rhs' <- transformExp $ addLetDecls srcloc rnps rhs+	case guards of +	 -- There were no guards before, and none should be added,+	 -- so we still have an unguarded right-hand side+	 [] -> return $ HsUnGuardedRhs rhs'+	 -- There are guards to add. These should be added as pattern+	 -- guards, i.e. as statements.+	 _  -> return $ HsGuardedRhss [HsGuardedRhs srcloc (map mkStmtGuard guards) rhs']+mkRhs _ guards rnps (HsGuardedRhss gdrhss) = fmap HsGuardedRhss $ mapM (mkGRhs guards rnps) gdrhss+  where mkGRhs :: [Guard] -> [(HsName, HsPat)] -> HsGuardedRhs -> HsxM HsGuardedRhs+	mkGRhs gs rnps (HsGuardedRhs s oldgs rhs) = do+		-- Add the postponed patterns to the right-hand side by placing+		-- them in a let-expression to make them lazily evaluated.+		-- Then transform the whole right-hand side as an expression.+		rhs' <- transformExp $ addLetDecls s rnps rhs+		-- Now there are guards, so first we need to transform those+		oldgs' <- fmap concat $ mapM (transformStmt Guard) oldgs+		-- ... and then prepend the newly generated ones, as statements+		return $ HsGuardedRhs s ((map mkStmtGuard gs) ++ oldgs') rhs'++-- | Place declarations of postponed regular patterns in a let-expression to+-- make them lazy, in order to make them behave as irrefutable patterns.+addLetDecls :: SrcLoc -> [(HsName, HsPat)] -> HsExp -> HsExp+addLetDecls s []   e = e 	-- no declarations to add+addLetDecls s rnps e = +	-- Place all postponed patterns in the same let-expression+	letE (map (mkDecl s) rnps) e++-- | Make pattern binds from postponed regular patterns+mkDecl :: SrcLoc -> (HsName, HsPat) -> HsDecl+mkDecl srcloc (n,p) = patBind srcloc p (var n)++------------------------------------------------------------------------------------+-- Expressions+	  		   	 +-- | Transform expressions by traversing subterms.+-- Of special interest are expressions that contain patterns as subterms,+-- i.e. @let@, @case@ and lambda expressions, and also list comprehensions+-- and @do@-expressions. All other expressions simply transform their+-- sub-expressions, if any.+-- Of special interest are of course also any xml expressions.+transformExp :: HsExp -> HsxM HsExp+transformExp e = case e of+	-- A standard xml tag should be transformed into an element of the+	-- XML datatype. Attributes should be made into a set of mappings, +	-- and children should be transformed.+	HsXTag _ name attrs mattr cs -> do+		-- Hey Pluto, look, we have XML in our syntax tree!+		setXmlTransformed+		let -- ... make tuples of the attributes+		    as = map mkAttr attrs+		-- ... transform the children+		cs' <- mapM transformChild cs+		-- ... and lift the values into the XML datatype.+		return $ paren $ metaMkTag name as mattr cs'++	  where	-- | Transform expressions appearing in child position of an xml tag.+		-- Expressions are first transformed, then wrapped in a call to+		-- @toXml@.+		transformChild :: HsExp -> HsxM HsExp+		transformChild e = do+			-- Transform the expression+			te <- transformExp e+			-- ... and apply the overloaded toXMLs to it+			return $ metaToXmls te+		    +	-- An empty xml tag should be transformed just as a standard tag,+	-- only that there are no children,+	HsXETag _ name attrs mattr -> do+		-- ... 'tis the season to be jolly, falalalalaaaa....+		setXmlTransformed+		let -- ... make tuples of the attributes   +		    as = map mkAttr attrs+		    -- ... and lift the values into the XML datatype.+		return $ paren $ metaMkETag name as mattr+	-- PCDATA should be lifted as a string into the XML datatype.+	HsXPcdata pcdata	-> do setXmlTransformed+				      return $ metaMkPcdata pcdata+	-- Escaped expressions should be treated as just expressions.+	HsXExpTag e		-> do setXmlTransformed+				      transformExp e+	+	-- Patterns as arguments to a lambda expression could be regular,+	-- but we cannot put the evaluation here since a lambda expression+	-- can have neither guards nor a where clause. Thus we must postpone +	-- them to a case expressions on the right-hand side.+	HsLambda s pats rhs -> do+		let -- First rename regular patterns+		    (ps, rnpss)  = unzip $ renameRPats pats+		    -- ... group them up to one big tuple+		    (rns, rps) = unzip (concat rnpss)+		    alt1 = alt s (pTuple rps) rhs+		    texp = varTuple rns+		    -- ... and put it all in a case expression, which+		    -- can then be transformed in the normal way.+                    e = if null rns then rhs else caseE texp [alt1]+		rhs' <- transformExp e+		return $ HsLambda s ps rhs'+	-- A let expression can contain regular patterns in the declarations, +	-- or in the expression that makes up the body of the let.+	HsLet (HsBDecls ds) e -> do+		-- Declarations appearing in a let expression must be transformed+		-- in a special way due to scoping, see later documentation.+		-- The body is transformed as a normal expression.+		ds' <- transformLetDecls ds+		e'  <- transformExp e+		return $ letE ds' e'+	-- Bindings of implicit parameters can appear either in ordinary let+	-- expressions (GHC), in dlet expressions (Hugs) or in a with clause+	-- (both). Such bindings are transformed in a special way. The body +	-- is transformed as a normal expression in all cases.+	HsLet (HsIPBinds is) e -> do+		is' <- mapM transformIPBind is+		e'  <- transformExp e+		return $ HsLet (HsIPBinds is') e'+	HsDLet ipbs e -> do+		ipbs' <- mapM transformIPBind ipbs+		e'    <- transformExp e+		return $ HsDLet ipbs' e'+	HsWith e ipbs -> do+		ipbs' <- mapM transformIPBind ipbs+		e'    <- transformExp e+		return $ HsWith e' ipbs'+	-- A case expression can contain regular patterns in the expression+	-- that is the subject of the casing, or in either of the alternatives.+	HsCase e alts -> do+		e'    <- transformExp e+		alts' <- mapM transformAlt alts+		return $ HsCase e' alts'+	-- A do expression can contain regular patterns in its statements.+	HsDo stmts -> do+		stmts' <- fmap concat $ mapM (transformStmt Do) stmts+		return $ HsDo stmts'+	HsMDo stmts -> do+		stmts' <- fmap concat $ mapM (transformStmt Do) stmts+		return $ HsMDo stmts'+	-- A list comprehension can contain regular patterns in the result +	-- expression, or in any of its statements.+	HsListComp e stmts	-> do+		e'     <- transformExp e+		stmts' <- fmap concat $ mapM (transformStmt ListComp) stmts+		return $ HsListComp e' stmts'+	-- All other expressions simply transform their immediate subterms.+	HsInfixApp e1 op e2	-> transform2exp e1 e2 +					(\e1 e2 -> HsInfixApp e1 op e2)+	HsApp e1 e2         	-> transform2exp e1 e2 HsApp+	HsNegApp e 	    	-> fmap HsNegApp $ transformExp e+	HsIf e1 e2 e3 	    	-> transform3exp e1 e2 e3 HsIf+	HsTuple es	    	-> fmap HsTuple $ mapM transformExp es+	HsList es	    	-> fmap HsList $ mapM transformExp es+	HsParen e	    	-> fmap HsParen $ transformExp e+	HsLeftSection e op  	-> do e' <- transformExp e+				      return $ HsLeftSection e' op+	HsRightSection op e 	-> fmap (HsRightSection op) $ transformExp e+	HsRecConstr n fus   	-> fmap (HsRecConstr n) $ mapM transformFieldUpdate fus+	HsRecUpdate e fus   	-> do e'   <- transformExp e+				      fus' <- mapM transformFieldUpdate fus+				      return $ HsRecUpdate e' fus'+	HsEnumFrom e	    	-> fmap HsEnumFrom $ transformExp e+	HsEnumFromTo e1 e2  	-> transform2exp e1 e2 HsEnumFromTo+	HsEnumFromThen e1 e2 	-> transform2exp e1 e2 HsEnumFromThen+	HsEnumFromThenTo e1 e2 e3 -> transform3exp e1 e2 e3 HsEnumFromThenTo+	HsExpTypeSig s e t	-> do e' <- transformExp e+				      return $ HsExpTypeSig s e' t+	HsFunctorUnit e		-> do e' <- transformExp e+                                      return $ HsSpliceExp $ HsParenSplice $ +                                          app sugarFun $ HsBracketExp $+                                              HsExpBracket e'+        HsFunctorCall e         -> do e' <- transformExp e+                                      return $ paren $ app callFun e'+	_			-> return e	-- Warning! Does not work with TH bracketed expressions ([| ... |])++  where transformFieldUpdate :: HsFieldUpdate -> HsxM HsFieldUpdate+	transformFieldUpdate (HsFieldUpdate n e) =+		fmap (HsFieldUpdate n) $ transformExp e+		+	transform2exp :: HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> HsxM HsExp+	transform2exp e1 e2 f = do e1' <- transformExp e1+				   e2' <- transformExp e2+				   return $ f e1' e2'+	+	transform3exp :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> HsExp) -> HsxM HsExp+	transform3exp e1 e2 e3 f = do e1' <- transformExp e1+				      e2' <- transformExp e2+				      e3' <- transformExp e3+				      return $ f e1' e2' e3'++	mkAttr :: HsXAttr -> HsExp+	mkAttr (HsXAttr name e) = +		paren (metaMkName name `metaAssign` e)+++-- | Transform pattern bind declarations inside a @let@-expression by transforming +-- subterms that could appear as regular patterns, as well as transforming the bound+-- pattern itself. The reason we need to do this in a special way is scoping, i.e.+-- in the expression @let a | Just b <- match a = list in b@ the variable b will not+-- be in scope after the @in@. And besides, we would be on thin ice even if it was in+-- scope since we are referring to the pattern being bound in the guard that will+-- decide if the pattern will be bound... yikes, why does Haskell allow guards on +-- pattern binds to refer to the patterns being bound, could that ever lead to anything+-- but an infinite loop??+transformLetDecls :: [HsDecl] -> HsxM [HsDecl]+transformLetDecls ds = do+	-- We need to rename regular patterns in pattern bindings, since we need to+	-- separate the generated declaration sets. This since we need to add them not+	-- to the actual binding but rather to the declaration that will be the guard+	-- of the binding.+	let ds' = renameLetDecls ds +	transformLDs 0 0 ds'+  where transformLDs :: Int -> Int -> [HsDecl] -> HsxM [HsDecl]+  	transformLDs k l ds = case ds of+  	    []     -> return []+  	    (d:ds) -> case d of+  		HsPatBind srcloc pat rhs decls -> do+			-- We need to transform all pattern bindings in a set of+		  	-- declarations in the same context w.r.t. generating fresh+		  	-- variable names, since they will all be in scope at the same time.+		  	([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns [pat])+			decls' <- case decls of+			    -- Any declarations already in place should be left where they+			    -- are since they probably refer to the generating right-hand+			    -- side of the pattern bind. If they don't, we're in trouble...+			    HsBDecls decls -> fmap HsBDecls $ transformLetDecls decls+			    -- If they are implicit parameter bindings we simply transform+			    -- them as such.+			    HsIPBinds decls -> fmap HsIPBinds $ mapM transformIPBind decls+			-- The generated guard, if any, should be a declaration, and the+			-- generated declarations should be associated with it.+			let gs' = case gs of+				   []  -> []+				   [g] -> [mkDeclGuard g ws]+				   _   -> error "This should not happen since we \ +						   \ have called renameLetDecls already!"+			    -- Generated attribute guards should also be added as declarations,+			    -- but with no where clauses.+			    ags' = map (flip mkDeclGuard $ []) ags+			-- We must transform the right-hand side as well, but there are+			-- no new guards, nor any postponed patterns, to supply at this time.+			rhs' <- mkRhs srcloc [] [] rhs+			-- ... and then we should recurse with the new gensym argument.+			ds' <- transformLDs k' l' ds+			-- The generated guards, which should be at most one, should be+			-- added as declarations rather than as guards due to the+			-- scoping issue described above.+			return $ (HsPatBind srcloc pat' rhs' decls') : ags' ++ gs' ++ ds'++  	    	-- We only need to treat pattern binds separately, other declarations+  	    	-- can be transformed normally.+		d -> do d'  <- transformDecl d +			ds' <- transformLDs k l ds+			return $ d':ds'+++-- | Transform binding of implicit parameters by transforming the expression on the +-- right-hand side. The left-hand side can only be an implicit parameter, so no+-- regular patterns there...+transformIPBind :: HsIPBind -> HsxM HsIPBind+transformIPBind (HsIPBind s n e) =+	fmap (HsIPBind s n) $ transformExp e++------------------------------------------------------------------------------------+-- Statements of various kinds++-- | A simple annotation datatype for statement contexts.+data StmtType = Do | Guard | ListComp++-- | Transform statements by traversing and transforming subterms.+-- Since generator statements have slightly different semantics +-- depending on their context, statements are annotated with their+-- context to ensure that the semantics of the resulting statement+-- sequence is correct. The return type is a list since generated+-- guards will be added as statements on the same level as the+-- statement to be transformed.+transformStmt :: StmtType -> HsStmt -> HsxM [HsStmt]+transformStmt t s = case s of+	-- Generators can have regular patterns in the result pattern on the+	-- left-hand side and in the generating expression.+	HsGenerator s p e -> do+		let -- We need to treat generated guards differently depending+		    -- on the context of the statement.+		    guardFun = case t of+				Do	 -> monadify+				ListComp -> monadify+				Guard	 -> mkStmtGuard+		    -- Preserve semantics of irrefutable regular patterns by postponing+		    -- their evaluation to a let-expression on the right-hand side+		    ([p'], rnpss) = unzip $ renameIrrPats [p]+		-- Transform the pattern itself+		([p''], ags, gs, ds) <- transformPatterns [p']+		-- Put the generated declarations in a let-statement+		let lt  = case ds of+			   [] -> []+			   _  -> [letStmt ds]+		    -- Perform the designated trick on the generated guards.+		    gs' = map guardFun (ags ++ gs)+		-- Add the postponed patterns to the right-hand side by placing+		-- them in a let-expression to make them lazily evaluated.+		-- Then transform the whole right-hand side as an expression.+		e' <- transformExp $ addLetDecls s (concat rnpss) e+		return $ HsGenerator s p'' e':lt ++ gs'+	  where monadify :: Guard -> HsStmt+	  	-- To monadify is to create a statement guard, only that the+	  	-- generation must take place in a monad, so we need to "return"+	  	-- the value gotten from the guard.+		monadify (s,p,e) = genStmt s p (metaReturn $ paren e)+	-- Qualifiers are simply wrapped expressions and are treated as such.+	HsQualifier e -> fmap (\e -> [HsQualifier $ e]) $ transformExp e+	-- Let statements suffer from the same problem as let expressions, so+	-- the declarations should be treated in the same special way.+	HsLetStmt (HsBDecls ds)  -> +		fmap (\ds -> [letStmt ds]) $ transformLetDecls ds+	-- If the bindings are of implicit parameters we simply transform them as such.+	HsLetStmt (HsIPBinds is) -> +		fmap (\is -> [HsLetStmt (HsIPBinds is)]) $ mapM transformIPBind is+++------------------------------------------------------------------------------------------+-- Case alternatives++-- | Transform alternatives in a @case@-expression. Patterns are+-- transformed, while other subterms are traversed further.+transformAlt :: HsAlt -> HsxM HsAlt+transformAlt (HsAlt srcloc pat rhs decls) = do+	-- Preserve semantics of irrefutable regular patterns by postponing+	-- their evaluation to a let-expression on the right-hand side+  	let ([pat'], rnpss) = unzip $ renameIrrPats [pat]+  	-- Transform the pattern itself+  	([pat''], attrGuards, guards, decls'') <- transformPatterns [pat']+	-- Transform the right-hand side, and add any generated guards+	-- and let expressions to it.+  	rhs' <- mkGAlts srcloc (attrGuards ++ guards) (concat rnpss) rhs+	-- Transform declarations in the where clause, adding any generated+	-- declarations to it.+  	decls' <- case decls of+  		   HsBDecls ds -> do ds' <- mapM transformDecl ds+  		   		     return $ HsBDecls $ decls'' ++ ds+  		   _ 	       -> error "Cannot bind implicit parameters in the \+  		  		     \ \'where\' clause of a function using regular patterns."++	return $ HsAlt srcloc pat'' rhs' decls'+	+	-- Transform and update guards and right-hand side of a case-expression.+	-- The supplied list of guards is prepended to the original guards, and +	-- subterms are traversed and transformed.+  where	mkGAlts :: SrcLoc -> [Guard] -> [(HsName, HsPat)] -> HsGuardedAlts -> HsxM HsGuardedAlts+	mkGAlts s guards rnps (HsUnGuardedAlt rhs) = do+		-- Add the postponed patterns to the right-hand side by placing+		-- them in a let-expression to make them lazily evaluated.+		-- Then transform the whole right-hand side as an expression.+		rhs' <- transformExp $ addLetDecls s rnps rhs+		case guards of+		 -- There were no guards before, and none should be added,+		 -- so we still have an unguarded right-hand side+		 [] -> return $ HsUnGuardedAlt rhs'+		 -- There are guards to add. These should be added as pattern+		 -- guards, i.e. as statements.+		 _  -> return $ HsGuardedAlts [HsGuardedAlt s (map mkStmtGuard guards) rhs']+	mkGAlts s gs rnps (HsGuardedAlts galts) =+		fmap HsGuardedAlts $ mapM (mkGAlt gs rnps) galts+	  where mkGAlt :: [Guard] -> [(HsName, HsPat)] -> HsGuardedAlt -> HsxM HsGuardedAlt+		mkGAlt gs rnps (HsGuardedAlt s oldgs rhs) = do+			-- Add the postponed patterns to the right-hand side by placing+			-- them in a let-expression to make them lazily evaluated.+			-- Then transform the whole right-hand side as an expression.+			do rhs'   <- transformExp $ addLetDecls s rnps rhs+			    -- Now there are guards, so first we need to transform those+			   oldgs' <- fmap concat $ mapM (transformStmt Guard) oldgs+			    -- ... and then prepend the newly generated ones, as statements+			   return $ HsGuardedAlt s ((map mkStmtGuard gs) ++ oldgs') rhs'++----------------------------------------------------------------------------------+-- Guards++-- In some places, a guard will be a declaration instead of the+-- normal statement, so we represent it in a generic fashion.+type Guard = (SrcLoc, HsPat, HsExp)++mkStmtGuard :: Guard -> HsStmt+mkStmtGuard (s, p, e) = genStmt s p e++mkDeclGuard :: Guard -> [HsDecl] -> HsDecl+mkDeclGuard (s, p, e) ds = patBindWhere s p e ds++----------------------------------------------------------------------------------+-- Rewriting expressions before transformation.+-- Done in a monad for gensym capability.++newtype RN a = RN (RNState -> (a, RNState))++type RNState = Int++initRNState = 0++instance Monad RN where+ return a = RN $ \s -> (a,s)+ (RN f) >>= k = RN $ \s -> let (a,s') = f s+ 			       (RN g) = k a+ 			    in g s'++instance Functor RN where+ fmap f rna = do a <- rna+ 		 return $ f a+++runRename :: RN a -> a+runRename (RN f) = let (a,_) = f initRNState+		    in a++getRNState :: RN RNState+getRNState = RN $ \s -> (s,s)++setRNState :: RNState -> RN ()+setRNState s = RN $ \_ -> ((), s)++genVarName :: RN HsName+genVarName = do +	k <- getRNState+	setRNState $ k+1+	return $ name $ "harp_rnvar" ++ show k+++type NameBind = (HsName, HsPat)++-- Some generic functions on monads for traversing subterms++rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+rename1pat p f rn = do (q, ms) <- rn p+		       return (f q, ms)++rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+rename2pat p1 p2 f rn = do (q1, ms1) <- rn p1+			   (q2, ms2) <- rn p2+			   return $ (f q1 q2, ms1 ++ ms2)+			+renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+renameNpat ps f rn = do (qs, mss) <- fmap unzip $ mapM rn ps+			return (f qs, concat mss)+++++-- | Generate variables as placeholders for any regular patterns, in order+-- to place their evaluation elsewhere. We must likewise move the evaluation+-- of Tags because attribute lookups are force evaluation.+renameRPats :: [HsPat] -> [(HsPat, [NameBind])]+renameRPats ps = runRename $ mapM renameRP ps++renameRP :: HsPat -> RN (HsPat, [NameBind])+renameRP p = case p of+	-- We must rename regular patterns and Tag expressions+	HsPRPat _ _ 	    -> rename p+	HsPXTag _ _ _ _ _   -> rename p+	HsPXETag _ _ _ _    -> rename p+	-- The rest of the rules simply try to rename regular patterns in+	-- their immediate subpatterns.+	HsPNeg p    	    -> rename1pat p HsPNeg renameRP+	HsPInfixApp p1 n p2 -> rename2pat p1 p2+				(\p1 p2 -> HsPInfixApp p1 n p2)+				renameRP+	HsPApp n ps	    -> renameNpat ps (HsPApp n) renameRP+	HsPTuple ps	    -> renameNpat ps HsPTuple renameRP+	HsPList ps	    -> renameNpat ps HsPList renameRP+	HsPParen p	    -> rename1pat p HsPParen renameRP+	HsPRec n pfs	    -> renameNpat pfs (HsPRec n) renameRPf+	HsPAsPat n p	    -> rename1pat p (HsPAsPat n) renameRP+	HsPIrrPat p	    -> rename1pat p HsPIrrPat renameRP+	HsPXPatTag p	    -> rename1pat p HsPXPatTag renameRP+	HsPatTypeSig s p t  -> rename1pat p (\p -> HsPatTypeSig s p t) renameRP	+	_		    -> return (p, [])++  where renameRPf :: HsPatField -> RN (HsPatField, [NameBind])+  	renameRPf (HsPFieldPat n p) = rename1pat p (HsPFieldPat n) renameRP+  	+  	renameAttr :: HsPXAttr -> RN (HsPXAttr, [NameBind])+  	renameAttr (HsPXAttr s p) = rename1pat p (HsPXAttr s) renameRP+  	+  	rename :: HsPat -> RN (HsPat, [NameBind])+  	rename p = do -- Generate a fresh variable+  		      n <- genVarName+  		      -- ... and return that, along with the association of+		      -- the variable with the old pattern+  		      return (pvar n, [(n,p)])++-- | Rename declarations appearing in @let@s or @where@ clauses.+renameLetDecls :: [HsDecl] -> [HsDecl]+renameLetDecls ds = +	let -- Rename all regular patterns bound in pattern bindings.+	    (ds', smss) = unzip $ runRename $ mapM renameLetDecl ds+	    -- ... and then generate declarations for the associations+	    gs = map (\(s,n,p) -> mkDecl s (n,p)) (concat smss)+	    -- ... which should be added to the original list of declarations.+	 in ds' ++ gs++  where	renameLetDecl :: HsDecl -> RN (HsDecl, [(SrcLoc, HsName, HsPat)])+	renameLetDecl d = case d of+		-- We need only bother about pattern bindings.+		HsPatBind srcloc pat rhs decls -> do+			-- Rename any regular patterns that appear in the+			-- pattern being bound.+			(p, ms) <- renameRP pat+			let sms = map (\(n,p) -> (srcloc, n, p)) ms+			return $ (HsPatBind srcloc p rhs decls, sms)+		_ -> return (d, [])+++-- | Move irrefutable regular patterns into a @let@-expression instead,+-- to make sure that the semantics of @~@ are preserved.+renameIrrPats :: [HsPat] -> [(HsPat, [NameBind])]+renameIrrPats ps = runRename (mapM renameIrrP ps)++renameIrrP :: HsPat -> RN (HsPat, [(HsName, HsPat)])+renameIrrP p = case p of+	-- We should rename any regular pattern appearing+	-- inside an irrefutable pattern.+	HsPIrrPat p	    -> do (q, ms) <- renameRP p+				  return $ (HsPIrrPat q, ms)+	-- The rest of the rules simply try to rename regular patterns in+	-- irrefutable patterns in their immediate subpatterns.+	HsPNeg p    	    -> rename1pat p HsPNeg renameIrrP+	HsPInfixApp p1 n p2 -> rename2pat p1 p2+				(\p1 p2 -> HsPInfixApp p1 n p2)+				renameIrrP+	HsPApp n ps	    -> renameNpat ps (HsPApp n) renameIrrP+	HsPTuple ps	    -> renameNpat ps HsPTuple renameIrrP+	HsPList ps	    -> renameNpat ps HsPList renameIrrP+	HsPParen p	    -> rename1pat p HsPParen renameIrrP+	HsPRec n pfs	    -> renameNpat pfs (HsPRec n) renameIrrPf+	HsPAsPat n p	    -> rename1pat p (HsPAsPat n) renameIrrP+	HsPatTypeSig s p t  -> rename1pat p (\p -> HsPatTypeSig s p t) renameIrrP	++	-- Hsx+	HsPXTag s n attrs mat p -> do (attrs', nss) <- fmap unzip $ mapM renameIrrAttr attrs+				      (mat', ns1) <- case mat of+				      	       	      Nothing -> return (Nothing, [])+				      	              Just at -> do (at', ns) <- renameIrrP at+				      	              		    return (Just at', ns)+				      (q, ns) <- rename1pat p (HsPXTag s n attrs' mat') renameIrrP+				      return (q, concat nss ++ ns1 ++ ns)+	HsPXETag s n attrs mat	-> do (as, nss) <- fmap unzip $ mapM renameIrrAttr attrs+				      (mat', ns1) <- case mat of+				      	       	      Nothing -> return (Nothing, [])+				      	              Just at -> do (at', ns) <- renameIrrP at+				      	              		    return (Just at', ns)+				      return $ (HsPXETag s n as mat', concat nss ++ ns1)+	HsPXPatTag p	    	-> rename1pat p HsPXPatTag renameIrrP+	-- End Hsx++	_		    -> return (p, [])+	+  where renameIrrPf :: HsPatField -> RN (HsPatField, [NameBind])+  	renameIrrPf (HsPFieldPat n p) = rename1pat p (HsPFieldPat n) renameIrrP+  	+  	renameIrrAttr :: HsPXAttr -> RN (HsPXAttr, [NameBind])+  	renameIrrAttr (HsPXAttr s p) = rename1pat p (HsPXAttr s) renameIrrP+-----------------------------------------------------------------------------------+-- Transforming Patterns: the real stuff++-- | Transform several patterns in the same context, thereby+-- generating any code for matching regular patterns.+transformPatterns :: [HsPat] -> HsxM ([HsPat], [Guard], [Guard], [HsDecl])+transformPatterns ps = runTr (trPatterns ps)++---------------------------------------------------+-- The transformation monad++type State = (Int, Int, Int, [Guard], [Guard], [HsDecl])++newtype Tr a = Tr (State -> HsxM (a, State))++instance Monad Tr where+ return a = Tr $ \s -> return (a, s)+ (Tr f) >>= k = Tr $ \s ->+ 		  do (a, s') <- f s+ 		     let (Tr f') = k a+ 		     f' s'++instance Functor Tr where+ fmap f tra = tra >>= (return . f)++liftTr :: HsxM a -> Tr a+liftTr hma = Tr $ \s -> do a <- hma+			   return (a, s)++initState = initStateFrom 0 0++initStateFrom k l = (0, k, l, [], [], [])++runTr :: Tr a -> HsxM (a, [Guard], [Guard], [HsDecl])+runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState+		  return (a, reverse gs1, reverse gs2, reverse ds)+++runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard], [Guard], [HsDecl], Int, Int)+runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l+			    return (a, reverse gs1, reverse gs2, reverse ds, k', l')+++-- manipulating the state+getState :: Tr State+getState = Tr $ \s -> return (s,s)++setState :: State -> Tr ()+setState s = Tr $ \_ -> return ((),s)++updateState :: (State -> (a,State)) -> Tr a+updateState f = do s <- getState+		   let (a,s') = f s+		   setState s'+		   return a++-- specific state manipulating functions+pushGuard :: SrcLoc -> HsPat -> HsExp -> Tr ()+pushGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(s,p,e):gs2,ds))+		 +pushDecl :: HsDecl -> Tr ()+pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))++pushAttrGuard :: SrcLoc -> HsPat -> HsExp -> Tr ()+pushAttrGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(s,p,e):gs1,gs2,ds))++genMatchName :: Tr HsName+genMatchName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (n,(n+1,m,a,gs1,gs2,ds))+		  return $ HsIdent $ "harp_match" ++ show k++genPatName :: Tr HsName+genPatName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m+1,a,gs1,gs2,ds))+		return $ HsIdent $ "harp_pat" ++ show k++genAttrName :: Tr HsName+genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))+		 return $ HsIdent $ "hsx_attrs" ++ show k+++setHarpTransformedT, setXmlTransformedT :: Tr ()+setHarpTransformedT = liftTr setHarpTransformed+setXmlTransformedT  = liftTr setXmlTransformed+++-------------------------------------------------------------------+-- Some generic functions for computations in the Tr monad. Could+-- be made even more general, but there's really no point right now...++tr1pat :: a -> (b -> c) -> (a -> Tr b) -> Tr c+tr1pat p f tr = do q <- tr p+		   return $ f q++tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c+tr2pat p1 p2 f tr = do q1 <- tr p1+		       q2 <- tr p2+		       return $ f q1 q2++trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c+trNpat ps f tr = do qs <- mapM tr ps+		    return $ f qs++-----------------------------------------------------------------------------+-- The *real* transformations+-- Transforming patterns++-- | Transform several patterns in the same context+trPatterns :: [HsPat] -> Tr [HsPat]+trPatterns = mapM trPattern++-- | Transform a pattern by traversing the syntax tree.+-- A regular pattern is translated, other patterns are +-- simply left as is.+trPattern :: HsPat -> Tr HsPat+trPattern p = case p of+	-- This is where the fun starts. =)+	-- Regular patterns must be transformed of course.+	HsPRPat s rps -> do+		-- First we need a name for the placeholder pattern.+		n <- genPatName +		-- A top-level regular pattern is a sequence in linear+		-- context, so we can simply translate it as if it was one.+		(mname, vars, _) <- trRPat s True (HsRPSeq rps)+		-- Generate a top level declaration.+		topmname <- mkTopDecl s mname vars+		-- Generate a pattern guard for this regular pattern,+		-- that will match the generated declaration to the +		-- value of the placeholder, and bind all variables.+		mkGuard s vars topmname n+		-- And indeed, we have made a transformation!+		setHarpTransformedT+		-- Return the placeholder pattern.+		return $ pvar n+	-- Tag patterns should be transformed+	HsPXTag s name attrs mattr cpat -> do+		-- We need a name for the attribute list, if there are lookups+		an <- case (mattr, attrs) of+			-- ... if there is one already, and there are no lookups+			-- we can just return that+			(Just ap, []) -> return $ ap+			      -- ... if there are none, we dont' care+			(_, []) -> return wildcard+			(_, _)  -> do -- ... but if there are, we want a name for that list+				      n <- genAttrName+				      -- ... we must turn attribute lookups into guards+				      mkAttrGuards s n attrs mattr+				      -- ... and we return the pattern+				      return $ pvar n+		-- ... the pattern representing children should be transformed+		cpat' <- trPattern cpat+		-- ...  we have made a transformation and should report that+		setHarpTransformedT+		-- ... and we return a Tag pattern.+		let (dom, n) = xNameParts name+		return $ metaTag dom n an cpat' +	-- ... as should empty Tag patterns+	HsPXETag s name attrs mattr -> do+		-- We need a name for the attribute list, if there are lookups+		an <- case (mattr, attrs) of+			-- ... if there is a pattern already, and there are no lookups+			-- we can just return that+			(Just ap, []) -> return $ ap+			      -- ... if there are none, we dont' care+			(_, []) -> return wildcard+			(_, _)  -> do -- ... but if there are, we want a name for that list+				      n <- genAttrName+				      -- ... we must turn attribute lookups into guards+				      mkAttrGuards s n attrs mattr+				      -- ... and we return the pattern+				      return $ pvar n+		-- ...  we have made a transformation and should report that+		setHarpTransformedT+		-- ... and we return an ETag pattern.+		let (dom, n) = xNameParts name+		return $ metaTag dom n an peList+	-- PCDATA patterns are strings in the xml datatype.+	HsPXPcdata s -> setHarpTransformedT >> (return $ metaPcdata s)+	-- XML comments are likewise just treated as strings.+	HsPXPatTag p -> setHarpTransformedT >> trPattern p++	-- Transforming any other patterns simply means transforming+	-- their subparts.+	HsPVar _	     -> return p+	HsPLit _	     -> return p+	HsPNeg q	     -> tr1pat q HsPNeg trPattern+	HsPInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> HsPInfixApp p1 op p2) trPattern+	HsPApp n ps	     -> trNpat ps (HsPApp n) trPattern+	HsPTuple ps	     -> trNpat ps HsPTuple trPattern+	HsPList ps	     -> trNpat ps HsPList trPattern+	HsPParen p	     -> tr1pat p HsPParen trPattern+	HsPRec n pfs	     -> trNpat pfs (HsPRec n) trPatternField+	HsPAsPat n p	     -> tr1pat p (HsPAsPat n) trPattern+	HsPWildCard	     -> return p+	HsPIrrPat p	     -> tr1pat p HsPIrrPat trPattern+	HsPatTypeSig s p t   -> tr1pat p (\p -> HsPatTypeSig s p t) trPattern++  where	-- Transform a pattern field.+  	trPatternField :: HsPatField -> Tr HsPatField+  	trPatternField (HsPFieldPat n p) = +  		tr1pat p (HsPFieldPat n) trPattern+ +	-- Deconstruct an xml tag name into its parts.+	xNameParts :: HsXName -> (Maybe String, String)+	xNameParts n = case n of+			HsXName s      -> (Nothing, s)+			HsXDomName d s -> (Just d, s)++	-- | Generate a guard for looking up xml attributes.+	mkAttrGuards :: SrcLoc -> HsName -> [HsPXAttr] -> Maybe HsPat -> Tr ()+	mkAttrGuards s attrs [HsPXAttr n q] mattr = do+		-- Apply lookupAttr to the attribute name and+		-- attribute set+		let rhs = metaExtract n attrs+		    -- ... catch the result+		    pat = metaPJust q+		    -- ... catch the remainder list+		    rml = case mattr of+		    	   Nothing -> wildcard+		    	   Just ap -> ap+		-- ... and add the generated guard to the store.+		pushAttrGuard s (pTuple [pat, rml]) rhs++	mkAttrGuards s attrs ((HsPXAttr a q):xs) mattr = do+		-- Apply lookupAttr to the attribute name and+		-- attribute set+		let rhs = metaExtract a attrs+		    -- ... catch the result+		    pat = metaPJust q+		-- ... catch the remainder list+		newAttrs <- genAttrName+		-- ... and add the generated guard to the store.+		pushAttrGuard s (pTuple [pat, pvar newAttrs]) rhs+		-- ... and finally recurse+		mkAttrGuards s newAttrs xs mattr+		    + 	-- | Generate a declaration at top level that will finalise all + 	-- variable continuations, and then return all bound variables.+	mkTopDecl :: SrcLoc -> HsName -> [HsName] -> Tr HsName+	mkTopDecl s mname vars = +		do -- Give the match function a name+		   n <- genMatchName +		   -- Create the declaration and add it to the store.+		   pushDecl $ topDecl s n mname vars+		   -- Return the name of the match function so that the+		   -- guard that will be generated can call it.+		   return n++	topDecl :: SrcLoc -> HsName -> HsName -> [HsName] -> HsDecl+	topDecl s n mname vs = +		let pat  = pTuple [wildcard, pvarTuple vs]	-- (_, (foo, bar, ...))+		    g    = var mname				-- harp_matchX+		    a    = genStmt s pat g			-- (_, (foo, ...)) <- harp_matchX+		    vars = map (\v -> app (var v) eList) vs	-- (foo [], bar [], ...)+		    b    = qualStmt $ metaReturn $ tuple vars	-- return (foo [], bar [], ...)+		    e    = doE [a,b]				-- do (...) <- harp_matchX+		    						--    return (foo [], bar [], ...)+	 	 in nameBind s n e		-- harp_matchY = do ....++	-- | Generate a pattern guard that will apply the @runMatch@+	-- function on the top-level match function and the input list,+	-- thereby binding all variables.+	mkGuard :: SrcLoc -> [HsName] -> HsName -> HsName -> Tr ()+	mkGuard s vars mname n = do+		let tvs = pvarTuple vars				-- (foo, bar, ...)+		    ge  = appFun runMatchFun [var mname, var n]		-- runMatch harp_matchX harp_patY+		pushGuard s (pApp just_name [tvs]) ge			-- Just (foo, bar, ...) , runMatch ...+++--------------------------------------------------------------------------------+-- Transforming regular patterns++-- | A simple datatype to annotate return values from sub-patterns+data MType = S		   -- Single element+	   | L MType	   -- List of ... , (/  /), *, ++	   | E MType MType -- Either ... or ... , (  |  )+	   | M MType	   -- Maybe ... , ?+++-- When transforming a regular sub-pattern, we need to know the+-- name of the function generated to match it, the names of all+-- variables it binds, and the type of its returned value.+type MFunMetaInfo = (HsName, [HsName], MType)+++-- | Transform away a regular pattern, generating code+-- to replace it.+trRPat :: SrcLoc -> Bool -> HsRPat -> Tr MFunMetaInfo+trRPat s linear rp = case rp of+    -- For an ordinary Haskell pattern we need to generate a+    -- base match function for the pattern, and a declaration+    -- that lifts that function into the matcher monad.+    HsRPPat p -> do mkBaseDecl s linear p+  +      where -- | Generate declarations for matching ordinary Haskell patterns+	    mkBaseDecl :: SrcLoc -> Bool -> HsPat -> Tr MFunMetaInfo+	    mkBaseDecl s linear p = case p of+		-- We can simplify a lot if the pattern is a wildcard or a variable+		HsPWildCard -> mkWCMatch s+		HsPVar v    -> mkVarMatch s linear v+		-- ... and if it is an embedded pattern tag, we can just skip it+		HsPXPatTag q -> mkBaseDecl s linear q++		-- ... otherwise we'll have to take the long way...+		p           -> do -- First do a case match on a single element+				  (name, vars, _) <- mkBasePat s linear p	+				  -- ... apply baseMatch to the case matcher to +				  -- lift it into the matcher monad.+				  newname <- mkBaseMatch s name	+				  -- ... and return the meta-info gathered.+				  return (newname, vars, S)++	    -- | Generate a declaration for matching a variable.+	    mkVarMatch :: SrcLoc -> Bool -> HsName -> Tr MFunMetaInfo+	    mkVarMatch s linear v = do+		-- First we need a name for the new match function.+		n <- genMatchName+		-- Then we need a basic matching function that always matches,+		-- and that binds the value matched to the variable in question.+		let e = paren $ lamE s [pvar v] $		-- (\v -> Just (mf v))+				  app (var just_name) +				  (paren $ retVar linear v)+		-- Lift the function into the matcher monad, and bind it to its name,+		-- then add it the declaration to the store.+		pushDecl $ nameBind s n $+			      app baseMatchFun e	-- harp_matchX = baseMatch (\v -> Just (mf v))+		return (n, [v], S)			-- always binds v and only v++	      where retVar :: Bool -> HsName -> HsExp+		    retVar linear v +		    	-- if bound in linear context, apply const+			| linear    = metaConst (var v)+			-- if bound in non-linear context, apply (:)+			| otherwise = app consFun (var v)   ++	    -- | Generate a declaration for matching a wildcard+	    mkWCMatch :: SrcLoc -> Tr MFunMetaInfo+	    mkWCMatch s = do +		-- First we need a name...+		n <- genMatchName+		-- ... and then a function that always matches, discarding the result+		let e = paren $ lamE s [wildcard] $ 	-- (\_ -> Just ())+				    app (var just_name) unit_con+		-- ... which we lift, bind, and add to the store.+		pushDecl $ nameBind s n $ 		-- harp_matchX = baseMatch (\_ -> Just ())+			     app baseMatchFun e+		return (n, [], S)	-- no variables bound, hence []++	    -- | Generate a basic function that cases on a single element, +	    -- returning Just (all bound variables) on a match, and+	    -- Nothing on a mismatch.+	    mkBasePat :: SrcLoc -> Bool -> HsPat -> Tr MFunMetaInfo+	    mkBasePat s b p = +		do -- First we need a name...+		   n <- genMatchName+		   -- ... and then we need to know what variables that +		   -- will be bound by this match.+		   let vs = gatherPVars p+		   -- ... and then we can create and store away a casing function.+		   basePatDecl s b n vs p >>= pushDecl+		   return (n, vs, S)++	      where -- | Gather up the names of all variables in a pattern,+		    -- using a simple fold over the syntax structure.+		    gatherPVars :: HsPat -> [HsName]+		    gatherPVars p = case p of+			HsPVar v	     -> [v]+			HsPNeg q	     -> gatherPVars q+			HsPInfixApp p1 _ p2  -> gatherPVars p1 +++						 gatherPVars p2+			HsPApp _ ps	     -> concatMap gatherPVars ps +			HsPTuple ps	     -> concatMap gatherPVars ps +			HsPList ps	     -> concatMap gatherPVars ps +			HsPParen p	     -> gatherPVars p+			HsPRec _ pfs	     -> concatMap help pfs+				where help (HsPFieldPat _ p) = gatherPVars p+			HsPAsPat n p	     -> n : gatherPVars p+			HsPWildCard	     -> []+			HsPIrrPat p	     -> gatherPVars p+			HsPatTypeSig _ p _   -> gatherPVars p+			HsPRPat _ rps	     -> concatMap gatherRPVars rps+			HsPXTag _ _ attrs mattr cp -> +				concatMap gatherAttrVars attrs ++ gatherPVars cp +++					case mattr of+					 Nothing -> []+					 Just ap -> gatherPVars ap+			HsPXETag _ _ attrs mattr -> +				concatMap gatherAttrVars attrs ++ +					case mattr of+					 Nothing -> []+					 Just ap -> gatherPVars ap+			HsPXPatTag p	     -> gatherPVars p+			_		     -> []++		    gatherRPVars :: HsRPat -> [HsName]+		    gatherRPVars rp = case rp of+			HsRPStar rq	   -> gatherRPVars rq+			HsRPStarG rq	   -> gatherRPVars rq+			HsRPPlus rq 	   -> gatherRPVars rq+			HsRPPlusG rq	   -> gatherRPVars rq+			HsRPOpt rq	   -> gatherRPVars rq+			HsRPOptG rq	   -> gatherRPVars rq+			HsRPEither rq1 rq2 -> gatherRPVars rq1 ++ gatherRPVars rq2+			HsRPSeq rqs	   -> concatMap gatherRPVars rqs+			HsRPCAs n rq	   -> n : gatherRPVars rq+			HsRPAs n rq	   -> n : gatherRPVars rq+			HsRPParen rq	   -> gatherRPVars rq+			HsRPPat q	   -> gatherPVars q+		+		    gatherAttrVars :: HsPXAttr -> [HsName]+		    gatherAttrVars (HsPXAttr _ p) = gatherPVars p++	    -- | Generate a basic casing function for a given pattern.	+	    basePatDecl :: SrcLoc -> Bool -> HsName -> [HsName] -> HsPat -> Tr HsDecl+	    basePatDecl s linear f vs p = do+		-- We can use the magic variable harp_a since nothing else needs to+		-- be in scope at this time (we could use just a, or foo, or whatever)+		let a = HsIdent $ "harp_a"+		-- ... and we should case on that variable on the right-hand side.+		rhs <- baseCaseE s linear p a vs	-- case harp_a of ...+		-- The result is a simple function with one paramenter and+		-- the right-hand side we just generated.+		return $ simpleFun s f a rhs+	      where baseCaseE :: SrcLoc -> Bool -> HsPat -> HsName -> [HsName] -> Tr HsExp+		    baseCaseE s b p a vs = do+			-- First the alternative if we actually +			-- match the given pattern+			let alt1 = alt s p 				    -- foo -> Just (mf foo)+				    (app (var just_name) $ +				     tuple (map (retVar b) vs))+			    -- .. and finally an alternative for not matching the pattern.+			    alt2 = alt s wildcard (var nothing_name)	    -- _ -> Nothing+			-- ... and that pattern could itself contain regular patterns+			-- so we must transform away these.+			alt1' <- liftTr $ transformAlt alt1+			return $ caseE (var a) [alt1', alt2]+		    retVar :: Bool -> HsName -> HsExp+		    retVar linear v+		        -- if bound in linear context, apply const+			| linear    = metaConst (var v)+			-- if bound in non-linear context, apply (:)+			| otherwise = app consFun (var v)++	    -- | Generate a match function that lift the result of the+	    -- basic casing function into the matcher monad.+	    mkBaseMatch :: SrcLoc -> HsName -> Tr HsName+	    mkBaseMatch s name = +		do -- First we need a name...+		   n <- genMatchName+		   -- ... to which we bind the lifting function+		   pushDecl $ baseMatchDecl s n name+		   -- and then return for others to use.+		   return n++	    -- | Generate a declaration for the function that lifts a simple+	    -- casing function into the matcher monad.+	    baseMatchDecl :: SrcLoc -> HsName -> HsName -> HsDecl+	    baseMatchDecl s newname oldname = +		-- Apply the lifting function "baseMatch" to the casing function+		let e = app baseMatchFun (var oldname)+		    -- ... and bind it to the new name.+		 in nameBind s newname e		-- harp_matchX = baseMatch harp_matchY+++    -- For a sequence of regular patterns, we should transform all+    -- sub-patterns and then generate a function for sequencing them.+    HsRPSeq rps -> do +    	nvts <- mapM (trRPat s linear) rps+	mkSeqDecl s nvts+	+      where -- | Generate a match function for a sequence of regular patterns,+	    -- flattening any special sub-patterns into normal elements of the list+	    mkSeqDecl :: SrcLoc -> [MFunMetaInfo] -> Tr MFunMetaInfo+	    mkSeqDecl s nvts = do+	    	-- First, as always, we need a name...+		name <- genMatchName+	     	let -- We need a generating statement for each sub-pattern.+	     	    (gs, vals) = unzip $ mkGenExps s 0 nvts		-- (harp_valX, (foo, ...)) <- harp_matchY+	     	    -- Gather up all variables from all sub-patterns.+		    vars    = concatMap (\(_,vars,_) -> vars) nvts+		    -- ... flatten all values to simple lists, and concatenate+		    -- the lists to a new return value+		    fldecls = flattenVals s vals			-- harp_valXf = $flatten harp_valX+		    							-- harp_ret = foldComp [harp_val1f, ...]+		    -- ... return the value along with all variables+		    ret     = qualStmt $ metaReturn $			-- return (harp_ret, (foo, .....))+		    		tuple [var retname, varTuple vars]+		    -- ... do all these steps in a do expression+		    rhs	    = doE $ gs ++ 				-- do (harp_valX, (foo, ...)) <- harpMatchY+				[letStmt fldecls, ret]			--    let harp_valXf = $flatten harp_valX+									--    return (harp_ret, (foo, .....))+		-- ... bind it to its name, and add the declaration+		-- to the store.+		pushDecl $ nameBind s name rhs 				-- harp_matchZ = do ....+		-- The return value of a sequence is always a list of elements.+		return (name, vars, L S)++	    -- | Flatten values of all sub-patterns into normal elements of the list+	    flattenVals :: SrcLoc -> [(HsName, MType)] -> [HsDecl]+	    flattenVals s nts = +		let -- Flatten the values of all sub-patterns to +		    -- lists of elements+		    (nns, ds) = unzip $ map (flVal s) nts+		    -- ... and concatenate their results.+		    ret       = nameBind s retname $ app+				  (paren $ app foldCompFun +				    (listE $ map var nns)) $ eList+		 in ds ++ [ret]+	+	+	    flVal :: SrcLoc -> (HsName, MType) -> (HsName, HsDecl)+	    flVal s (name, mt) =+		let -- We reuse the old names, we just extend them a bit.+		    newname = extendVar name "f"	-- harp_valXf+		    -- Create the appropriate flattening function depending+		    -- on the type of the value+		    f       = flatten mt+		    -- ... apply it to the value and bind it to its new name.+		 in (newname, nameBind s newname $	-- harp_valXf = $flatten harp_valX+				app f (var name))++	    -- | Generate a flattening function for a given type structure.+	    flatten :: MType -> HsExp+	    flatten S = consFun				-- (:)+	    flatten (L mt) = +		let f = flatten mt+		    r = paren $ metaMap f+		 in paren $ foldCompFun	`metaComp` r	-- (foldComp . (map $flatten))+	    flatten (E mt1 mt2) = +		let f1 = flatten mt1+		    f2 = flatten mt2+		 in paren $ metaEither f1 f2		-- (either $flatten $flatten)+	    flatten (M mt) = +		let f = flatten mt+		 in paren $ metaMaybe idFun f		-- (maybe id $flatten)++    -- For accumulating as-patterns we should transform the subpattern, and then generate +    -- a declaration that supplies the value to be bound to the variable in question.+    -- The variable should be bound non-linearly.+    HsRPCAs v rp -> do +    	-- Transform the subpattern+    	nvt@(name, vs, mt) <- trRPat s linear rp+    	-- ... and create a declaration to bind its value.+	n <- mkCAsDecl s nvt+	-- The type of the value is unchanged.+	return (n, (v:vs), mt)++      where -- | Generate a declaration for a @: binding.+	    mkCAsDecl :: SrcLoc -> MFunMetaInfo -> Tr HsName+	    mkCAsDecl = asDecl $ app consFun	-- should become lists when applied to []+++    -- For ordinary as-patterns we should transform the subpattern, and then generate +    -- a declaration that supplies the value to be bound to the variable in question.+    -- The variable should be bound linearly.+    HsRPAs v rp +	| linear -> +	     do -- Transform the subpattern+		nvt@(name, vs, mt) <- trRPat s linear rp+		-- ... and create a declaration to bind its value+		n <- mkAsDecl s nvt+		-- The type of the value is unchanged.+		return (n, (v:vs), mt)+	-- We may not use an @ bind in non-linear context+	| otherwise -> case v of+		    	HsIdent n -> fail $ "Attempting to bind variable "++n+++					  " inside the context of a numerable regular pattern"+		    	_	      -> fail $ "This should never ever ever happen...\+						  \ how the #% did you do it??!?"++      where -- | Generate a declaration for a @ binding.+	    mkAsDecl :: SrcLoc -> MFunMetaInfo -> Tr HsName+	    mkAsDecl = asDecl metaConst		-- should be constant when applied to []+++    -- For regular patterns, parentheses have no real meaning+    -- so at this point we can just skip them.+    HsRPParen rp -> trRPat s linear rp+    +    -- For (possibly non-greedy) optional regular patterns we need to+    -- transform the subpattern, and the generate a function that can+    -- choose to match or not to match, that is the question...+    HsRPOpt rp -> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can optionally match it.+	   mkOptDecl s False nvt+    -- ... similarly for the non-greedy version.+    HsRPOptG rp -> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can optionally match it.+	   mkOptDecl s True nvt+++    -- For union patterns, we should transform both subexpressions,+    -- and generate a function that chooses between them.+    HsRPEither rp1 rp2 -> +    	do -- Transform the subpatterns+    	   nvt1 <- trRPat s False rp1+	   nvt2 <- trRPat s False rp2+	   -- ... and create a declaration that can choose between them.+	   mkEitherDecl s nvt1 nvt2+  	-- | Generate declarations for either patterns, i.e. ( | )+      where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo+            mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do+                -- Eine namen, bitte!+  		n <- genMatchName+  		let -- Generate generators for the subpatterns+  		    (g1, v1) = mkGenExp s nvt1+  		    (g2, v2) = mkGenExp s nvt2			-- (harp_valX, (foo, bar, ...)) <- harp_matchY+  		    -- ... gather all variables from both sides+  		    allvs = vs1 `union` vs2+  		    -- ... some may be bound on both sides, so we+  		    -- need to check which ones are bound on each,+  		    -- supplying empty value for those that are not+  		    vals1 = map (varOrId vs1) allvs		+  		    vals2 = map (varOrId vs2) allvs+  		    -- ... apply either Left or Right to the returned value+  		    ret1  = metaReturn $ tuple			-- return (Left harp_val1, (foo, id, ...))+  		    		[app (var left_name)+  		    		 (var v1), tuple vals1]+  		    ret2  = metaReturn $ tuple			-- return (Right harp_val2, (id, bar, ...))+  		    		[app (var right_name)+  		    		 (var v2), tuple vals2]+  		    -- ... and do all these things in do-expressions+  		    exp1  = doE [g1, qualStmt ret1]+  		    exp2  = doE [g2, qualStmt ret2]+  		    -- ... and choose between them using the choice (+++) operator.+  		    rhs   = (paren exp1) `metaChoice`		-- (do ...) +++ +  		    		(paren exp2)			--  (do ...)+  		-- Finally we create a declaration for this function and+  		-- add it to the store.+  		pushDecl $ nameBind s n rhs			-- harp_matchZ = (do ...) ...+  		-- The type of the returned value is Either the type of the first+  		-- or the second subpattern.+  		return (n, allvs, E t1 t2)+  		 +	    varOrId :: [HsName] -> HsName -> HsExp+	    varOrId vs v = if v `elem` vs 	-- the variable is indeed bound in this branch+	  			then var v 	-- ... so it should be added to the result+	  			else idFun	-- ... else it should be empty.++    -- For (possibly non-greedy) repeating regular patterns we need to transform the subpattern,+    -- and then generate a function to handle many matches of it.+    HsRPStar rp	-> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can match it many times.+	   mkStarDecl s False nvt+    -- ... and similarly for the non-greedy version.+    HsRPStarG rp -> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can match it many times.+	   mkStarDecl s True nvt++    -- For (possibly non-greedy) non-empty repeating patterns we need to transform the subpattern,+    -- and then generate a function to handle one or more matches of it.+    HsRPPlus rp	-> +	do -- Transform the subpattern+	   nvt <- trRPat s False rp+	   -- ... and create a declaration that can match it one or more times.+	   mkPlusDecl s False nvt+    -- ... and similarly for the non-greedy version.+    HsRPPlusG rp -> +	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+	   -- ... and create a declaration that can match it one or more times.+	   mkPlusDecl s True nvt+++  where -- These are the functions that must be in scope for more than one case alternative above.+  +  	-- | Generate the generators that call sub-matching functions, and+	-- annotate names with types for future flattening of values.+	-- Iterate to enable gensym-like behavior.+	mkGenExps :: SrcLoc -> Int -> [MFunMetaInfo] -> [(HsStmt, (HsName, MType))]+	mkGenExps _ _ [] = []+	mkGenExps s k ((name, vars, t):nvs) = +		let valname = mkValName k				-- harp_valX+		    pat     = pTuple [pvar valname, pvarTuple vars]	-- (harp_valX, (foo, bar, ...))+		    g	    = var name+		 in (genStmt s pat g, (valname, t)) : 			-- (harp_valX, (foo, ...)) <- harp_matchY+		 	mkGenExps s (k+1) nvs++	-- | Create a single generator.+	mkGenExp :: SrcLoc -> MFunMetaInfo -> (HsStmt, HsName)+	mkGenExp s nvt = let [(g, (name, _t))] = mkGenExps s 0 [nvt]+			  in (g, name)++	-- | Generate a single generator with a call to (ng)manyMatch,+	-- and an extra variable name to use after unzipping. +	mkManyGen :: SrcLoc -> Bool -> HsName -> HsStmt+	mkManyGen s greedy mname =+		-- Choose which repeater function to use, determined by greed+		let mf  = if greedy then gManyMatchFun else manyMatchFun+		 -- ... and create a generator that applies it to the+		 -- matching function in question.+		 in genStmt s (pvar valsvarsname) $ +		 	app mf (var mname)++	-- | Generate declarations for @: and @ bindings.+	asDecl :: (HsExp -> HsExp) -> SrcLoc -> MFunMetaInfo -> Tr HsName+	asDecl mf s nvt@(_, vs, _) = do+		-- A name, if you would+		n <- genMatchName					 -- harp_matchX+		let -- Generate a generator for matching the subpattern+		    (g, val) = mkGenExp s nvt				 -- (harp_valY, (foo, ...)) <- harp_matchZ+		    -- ... fix the old variables+		    vars     = map var vs				 -- (apa, bepa, ...)+		    -- ... and return the generated value, along with the+		    -- new set of variables which is the old set prepended+		    -- by the variable currently being bound.+		    ret = qualStmt $ metaReturn $ tuple			 -- return (harp_valY, ($mf harp_valY, apa, ...))+				[var val, tuple $ mf (var val) : vars] 	 -- mf in the line above is what separates+									 -- @: ((:)) from @ (const)+		-- Finally we create a declaration for this function and +		-- add it to the store.+		pushDecl $ nameBind s n $ doE [g, ret]			 -- harp_matchX = do ...+		return n++  	-- | Generate declarations for optional patterns, ? and #?.+  	-- (Unfortunally we must place this function here since both variations+  	-- of transformations of optional patterns should be able to call it...)+  	mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+  	mkOptDecl s greedy nvt@(_, vs, t) = do+  		-- Un nome, s'il vouz plaît.+  		n <- genMatchName+  		let -- Generate a generator for matching the subpattern+  		    (g, val) = mkGenExp s nvt			-- (harp_valX, (foo, bar, ...)) <- harp_matchY+  		    -- ... and apply a Just to its value+  		    ret1 = metaReturn $ tuple 			-- return (Just harp_val1, (foo, bar, ...))+  				[app (var just_name) +  				 (var val), varTuple vs]+  		    -- ... and do those two steps in a do-expression+  		    exp1 = doE [g, qualStmt ret1]		-- do ....+  		    -- For the non-matching branch, all the variables should be empty+  		    ids  = map (const idFun) vs			-- (id, id, ...)+  		    -- ... and the value should be Nothing.+  		    ret2 = metaReturn $ tuple			-- return (Nothing, (id, id, ...))+  		    		[var nothing_name, tuple ids]	-- i.e. no vars were bound+  		    -- The order of the arguments to the choice (+++) operator +  		    -- is determined by greed...+  		    mc   = if greedy +  		    	    then metaChoice 	   -- standard order+  		    	    else (flip metaChoice) -- reversed order+  		    -- ... and then apply it to the branches.+  		    rhs  = (paren exp1) `mc` 			-- (do ....) +++ +  		    		(paren ret2)			--  (return (Nothing, .....))+  		-- Finally we create a declaration for this function and+  		-- add it to the store.+  		pushDecl $ nameBind s n rhs			-- harp_matchZ = (do ....) +++ (return ....)+  		-- The type of the returned value will be Maybe the type+  		-- of the value of the subpattern.+  		return (n, vs, M t)+ +  	-- | Generate declarations for star patterns, * and #*+  	-- (Unfortunally we must place this function here since both variations+  	-- of transformations of repeating patterns should be able to call it...)+  	mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+  	mkStarDecl s greedy (mname, vs, t) = do+  		-- Ett namn, tack!+  		n <- genMatchName+  		let -- Create a generator that matches the subpattern+  		    -- many times, either greedily or non-greedily+  		    g = mkManyGen s greedy mname+  		    -- ... and unzip the result, choosing the proper unzip+  		    -- function depending on the number of variables returned.+  		    metaUnzipK = mkMetaUnzip s (length vs)+  		    -- ... first unzip values from variables+  		    dec1    = patBind s (pvarTuple [valname, varsname])+  		    		(metaUnzip $ var valsvarsname)+  		    -- ... and then unzip the variables+  		    dec2    = patBind s (pvarTuple vs)+  		    		(metaUnzipK $ var varsname)+  		    -- ... fold all the values for variables+  		    retExps = map ((app foldCompFun) . var) vs+  		    -- ... and return value and variables+  		    ret     = metaReturn $ tuple $+  		    		[var valname, tuple retExps]+  		-- Finally we need to generate a function that does all this,+  		-- using a let-statement for the non-monadic stuff and a+  		-- do-expression to wrap it all in.+  		pushDecl $ nameBind s n $+  		  doE [g, letStmt [dec1, dec2], qualStmt ret]+  		-- The type of the returned value is a list ([]) of the+  		-- type of the subpattern.+  		return (n, vs, L t)+  		+  	-- | Generate declarations for plus patterns, + and #++  	-- (Unfortunally we must place this function here since both variations+  	-- of transformations of non-empty repeating patterns should be able to call it...)+  	mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+  	mkPlusDecl s greedy nvt@(mname, vs, t) = do+  		-- and now I've run out of languages...+  		n <- genMatchName+  		let k = length vs+  		    -- First we want a generator to match the+  		    -- subpattern exactly one time+  		    (g1, val1) = mkGenExp s nvt			-- (harp_valX, (foo, ...)) <- harpMatchY+  		    -- ... and then one that matches it many times.+  		    g2         = mkManyGen s greedy mname	-- harp_vvs <- manyMatch harpMatchY+  		    -- ... we want to unzip the result, using+  		    -- the proper unzip function+  		    metaUnzipK = mkMetaUnzip s k+  		    -- ... first unzip values from variables+  		    dec1    = patBind s 			-- (harp_vals, harp_vars) = unzip harp_vvs+  		    		(pvarTuple [valsname, varsname])+  		    		(metaUnzip $ var valsvarsname)+  		    -- .. now we need new fresh names for variables+  		    -- since the ordinary ones are already taken.+  		    vlvars  = genNames "harp_vl" k+  		    -- ... and then we can unzip the variables+  		    dec2    = patBind s (pvarTuple vlvars)	-- (harp_vl1, ...) = unzipK harp_vars+  		    		(metaUnzipK $ var varsname)+  		    -- .. and do the unzipping in a let-statement+		    letSt   = letStmt [dec1, dec2]+  		    -- ... fold variables from the many-match,+  		    -- prepending the variables from the single match+  		    retExps = map mkRetFormat $ zip vs vlvars	-- foo . (foldComp harp_vl1), ...+  		    -- ... prepend values from the single match to+  		    -- those of the many-match.+  		    retVal  = (var val1) `metaCons` +  		    		(var valsname)			-- harp_valX : harp_vals+  		    -- ... return all values and variables+  		    ret     = metaReturn $ tuple $		-- return (harp_valX:harpVals, +  		    		[retVal, tuple retExps]		--   (foo . (...), ...))+  		    -- ... and wrap all of it in a do-expression.+		    rhs     = doE [g1, g2, letSt, qualStmt ret]+  		-- Finally we create a declaration for this function and+  		-- add it to the store.+		pushDecl $ nameBind s n rhs+  		-- The type of the returned value is a list ([]) of the+  		-- type of the subpattern.+		return (n, vs, L t)++	  where mkRetFormat :: (HsName, HsName) -> HsExp+	  	mkRetFormat (v, vl) =+	  		-- Prepend variables using function composition.+	  		(var v) `metaComp`+	  		  (paren $ (app foldCompFun) $ var vl)+++--------------------------------------------------------------------------+-- HaRP-specific functions and ids++-- | Functions and ids from the @Match@ module, +-- used in the generated matching functions+runMatchFun, baseMatchFun, manyMatchFun, gManyMatchFun :: HsExp+runMatchFun = match_qual runMatch_name+baseMatchFun = match_qual baseMatch_name+manyMatchFun = match_qual manyMatch_name+gManyMatchFun = match_qual gManyMatch_name++runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: HsName+runMatch_name = HsIdent "runMatch"+baseMatch_name = HsIdent "baseMatch"+manyMatch_name = HsIdent "manyMatch"+gManyMatch_name = HsIdent "gManyMatch"++match_mod, match_qual_mod :: Module+match_mod = Module "Harp.Match"+match_qual_mod = Module "HaRPMatch"++functor_qual_mod = Module "FunctorSugar"++sugarFun = qvar functor_qual_mod $ HsIdent "functorSugar"+callFun = qvar functor_qual_mod $ HsIdent "functorCall"++match_qual :: HsName -> HsExp+match_qual = qvar match_qual_mod++choiceOp :: HsQOp+choiceOp = HsQVarOp $ Qual match_qual_mod choice++appendOp :: HsQOp+appendOp = HsQVarOp $ UnQual append++-- foldComp = foldl (.) id, i.e. fold by composing+foldCompFun :: HsExp+foldCompFun = match_qual $ HsIdent "foldComp"++mkMetaUnzip :: SrcLoc -> Int -> HsExp -> HsExp+mkMetaUnzip s k | k <= 7 = let n = "unzip" ++ show k+	      		    in (\e -> matchFunction n [e])+	        | otherwise = +		   let vs      = genNames "x" k+	      	       lvs     = genNames "xs" k+		       uz      = name $ "unzip" ++ show k+		       ys      = name "ys"+		       xs      = name "xs"+		       alt1    = alt s peList $ tuple $ replicate k eList	-- [] -> ([], [], ...)+		       pat2    = (pvarTuple vs) `metaPCons` (pvar xs)		-- (x1, x2, ...)+		       ret2    = tuple $ map appCons $ zip vs lvs		-- (x1:xs1, x2:xs2, ...)+		       rhs2    = app (var uz) (var xs)				-- unzipK xs+		       dec2    = patBind s (pvarTuple lvs) rhs2			-- (xs1, xs2, ...) = unzipK xs+		       exp2    = letE [dec2] ret2+		       alt2    = alt s pat2 exp2+		       topexp  = lamE s [pvar ys] $ caseE (var ys) [alt1, alt2]+		       topbind = nameBind s uz topexp+		    in app (paren $ letE [topbind] (var uz))+  where appCons :: (HsName, HsName) -> HsExp+  	appCons (x, xs) = metaCons (var x) (var xs)++matchFunction :: String -> [HsExp] -> HsExp+matchFunction s es = mf s (reverse es)+  where mf s []     = match_qual $ HsIdent s+  	mf s (e:es) = app (mf s es) e++-- | Some 'magic' gensym-like functions, and functions+-- with related functionality.+retname :: HsName+retname = name "harp_ret"++varsname :: HsName+varsname = name "harp_vars"++valname :: HsName+valname = name "harp_val"++valsname :: HsName+valsname = name "harp_vals"++valsvarsname :: HsName+valsvarsname = name "harp_vvs"++mkValName :: Int -> HsName+mkValName k = name $ "harp_val" ++ show k++extendVar :: HsName -> String -> HsName+extendVar (HsIdent n) s = HsIdent $ n ++ s+extendVar n _ = n++xNameParts :: HsXName -> (Maybe String, String)+xNameParts n = case n of+		HsXName s      -> (Nothing, s)+		HsXDomName d s -> (Just d, s)++---------------------------------------------------------+-- meta-level functions, i.e. functions that represent functions, +-- and that take arguments representing arguments... whew!++metaReturn, metaConst, metaMap, metaUnzip :: HsExp -> HsExp+metaReturn e = metaFunction "return" [e]+metaConst e  = metaFunction "const" [e]+metaMap e    = metaFunction "map" [e]+metaUnzip e  = metaFunction "unzip" [e]++metaEither, metaMaybe :: HsExp -> HsExp -> HsExp+metaEither e1 e2 = metaFunction "either" [e1,e2]+metaMaybe e1 e2 = metaFunction "maybe" [e1,e2]++metaConcat :: [HsExp] -> HsExp+metaConcat es = metaFunction "concat" [listE es]++metaAppend :: HsExp -> HsExp -> HsExp+metaAppend l1 l2 = infixApp l1 appendOp l2++-- the +++ choice operator+metaChoice :: HsExp -> HsExp -> HsExp+metaChoice e1 e2 = infixApp e1 choiceOp e2++metaPCons :: HsPat -> HsPat -> HsPat+metaPCons p1 p2 = HsPInfixApp p1 cons p2++metaCons, metaComp :: HsExp -> HsExp -> HsExp+metaCons e1 e2 = infixApp e1 (HsQConOp cons) e2+metaComp e1 e2 = infixApp e1 (op fcomp) e2++metaPJust :: HsPat -> HsPat+metaPJust p = pApp just_name [p]++metaPNothing :: HsPat+metaPNothing = pvar nothing_name++metaPMkMaybe :: Maybe HsPat -> HsPat+metaPMkMaybe mp = case mp of+	Nothing -> metaPNothing+	Just p  -> pParen $ metaPJust p++metaJust :: HsExp -> HsExp+metaJust e = app (var just_name) e++metaNothing :: HsExp+metaNothing = var nothing_name++metaMkMaybe :: Maybe HsExp -> HsExp+metaMkMaybe me = case me of+	Nothing -> metaNothing+	Just e  -> paren $ metaJust e++---------------------------------------------------+-- some other useful functions at abstract level+consFun, idFun :: HsExp+consFun = HsCon cons+idFun = function "id"++cons :: HsQName+cons = Special HsCons++fcomp, choice, append :: HsName+fcomp = HsSymbol "."+choice = HsSymbol "+++"+append = HsSymbol "++"++just_name, nothing_name, left_name, right_name :: HsName+just_name = HsIdent "Just"+nothing_name = HsIdent "Nothing"+left_name = HsIdent "Left"+right_name = HsIdent "Right"++------------------------------------------------------------------------+-- Help functions for meta programming xml++hsx_data_mod :: Module+hsx_data_mod = Module "HSP.Data"++-- | Create an xml PCDATA value+metaMkPcdata :: String -> HsExp+metaMkPcdata s = metaFunction "pcdata" [strE s]++-- | Create an xml tag, given its domain, name, attributes and+-- children.+metaMkTag :: HsXName -> [HsExp] -> Maybe HsExp -> [HsExp] -> HsExp+metaMkTag name ats mat cs = +	let (d,n) = xNameParts name+	    ne    = tuple [metaMkMaybe $ fmap strE d, strE n]+	    m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaToAttribute x)) mat+	    attrs = m $ listE $ map metaToAttribute ats+	 in metaFunction "genTag" [ne, attrs, listE cs]++-- | Create an empty xml tag, given its domain, name and attributes.+metaMkETag :: HsXName -> [HsExp] -> Maybe HsExp -> HsExp+metaMkETag name ats mat = +	let (d,n) = xNameParts name+	    ne    = tuple [metaMkMaybe $ fmap strE d, strE n]+	    m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaToAttribute x)) mat+	    attrs = m $ listE $ map metaToAttribute ats+	 in metaFunction "genETag" [ne, attrs]++-- | Create an attribute by applying the overloaded @toAttribute@+metaToAttribute :: HsExp -> HsExp+metaToAttribute e = metaFunction "toAttribute" [e]++-- | Create a property from an attribute and a value.+metaAssign :: HsExp -> HsExp -> HsExp+metaAssign e1 e2 = infixApp e1 assignOp e2+  where assignOp = HsQVarOp $ UnQual $ HsSymbol ":="++-- | Make xml out of some expression by applying the overloaded function+-- @toXml@.+metaToXmls :: HsExp -> HsExp+metaToXmls e = metaFunction "toXMLs" [paren e]++-- | Lookup an attribute in the set of attributes.+metaExtract :: HsXName -> HsName -> HsExp+metaExtract name attrs = +	let (d,n) = xNameParts name+	    np    = tuple [metaMkMaybe $ fmap strE d, strE n]+	 in metaFunction "extract" [np, var attrs]++-- | Generate a pattern under the Tag data constructor.+metaTag :: (Maybe String) -> String -> HsPat -> HsPat -> HsPat+metaTag dom name ats cpat =+	let d = metaPMkMaybe $ fmap strP dom+	    n = pTuple [d, strP name]+	 in metaConPat "Tag" [n, ats, cpat]+	 +-- | Generate a pattern under the PCDATA data constructor.+metaPcdata :: String -> HsPat+metaPcdata s = metaConPat "PCDATA" [strP s]++metaMkName :: HsXName -> HsExp+metaMkName n = case n of+	HsXName s      -> strE s+	HsXDomName d s -> tuple [strE d, strE s]
+ Preprocessor/Main.hs view
@@ -0,0 +1,56 @@+module Main where++import Preprocessor.Hsx++import System.Environment (getArgs)+import Data.List (intersperse, isPrefixOf)++checkParse p = case p of+		  ParseOk m -> m+		  ParseFailed loc s -> error $ "Error at " ++ show loc ++ ":\n" ++ s++transformFile :: String -> String -> String -> IO ()+transformFile origfile infile outfile = do+	f <- readFile infile+	let fm = process origfile f+	writeFile outfile fm++testFile :: String -> IO ()+testFile file = do+	f <- readFile file+	putStrLn $ process file f+++testTransform :: String -> IO ()+testTransform file = do+	f <- readFile file+	putStrLn $ show $ transform $ checkParse $ parse file f+	+testPretty :: String -> IO ()+testPretty file = do+	f <- readFile file+	putStrLn $ prettyPrint $ checkParse $ parse file f++testParse :: String -> IO ()+testParse file = do+	f <- readFile file+	putStrLn $ show $ parse file f++main :: IO ()+main = do args <- getArgs+	  case args of+	   [origfile, infile, outfile] -> transformFile origfile infile outfile+	   [infile, outfile] -> transformFile infile infile outfile+	   [infile] -> testFile infile+	   _ -> putStrLn usageString+++process :: FilePath -> String -> String+process fp fc = prettyPrintWithMode (defaultMode {linePragmas=True}) $ +                 transform $ checkParse $ parse fp fc++parse fn fc = parseModuleWithMode (ParseMode fn) fcuc+  where fcuc= unlines $ filter (not . isPrefixOf "#") $ lines fc+++usageString = "Usage: trhsx <infile> [<outfile>]"
+ RDF.hs view
@@ -0,0 +1,135 @@+module RDF where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Cache+import Utils++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Set (Set)+import qualified Data.Set as Set++data Node = URI String | PlainLiteral String    deriving (Eq, Ord)+data Dir  = Pos | Neg                           deriving (Eq, Ord, Show)++instance Show Node where+    show (URI uri)        = showURI [("rdfs", rdfs)] uri+    show (PlainLiteral s) = "\"" ++ s ++ "\""++type Triple = (Node, Node, Node)+type Side   = Map Node (Map Node (Set Node))+data Graph  = Graph Side Side (Set Triple) deriving (Show, Eq)++instance Hashable Node where+    hash (URI s) = hash s+    hash (PlainLiteral s) = hash s+    +instance Hashable Dir where+    hash Pos = 0+    hash Neg = 1++rdfs         =     "http://www.w3.org/2000/01/rdf-schema#"+rdfs_label   = URI "http://www.w3.org/2000/01/rdf-schema#label"+rdfs_seeAlso = URI "http://www.w3.org/2000/01/rdf-schema#seeAlso"++showURI ((short, long):xs) uri | take (length long) uri == long =+                                     short ++ ":" ++ drop (length long) uri+                               | otherwise = showURI xs uri+showURI [] uri = "<" ++ uri ++ ">"++subject :: Triple -> Node+subject (s,_,_) = s++predicate :: Triple -> Node+predicate (_,p,_) = p++object :: Triple -> Node+object (_,_,o) = o++graphSide :: Dir -> Graph -> Side+graphSide Neg (Graph s _ _) = s+graphSide Pos (Graph _ s _) = s++hasConn :: Graph -> Node -> Node -> Dir -> Bool+hasConn g node prop dir = isJust $ do m <- Map.lookup node (graphSide dir g)+                                      Map.lookup prop m++getOne :: Graph -> Node -> Node -> Dir -> Maybe Node+getOne g node prop dir = if null nodes then Nothing else Just $ head nodes+    where nodes = Set.toList (getAll g node prop dir)+    +getAll :: Graph -> Node -> Node -> Dir -> Set Node+getAll g node prop dir = +    Map.findWithDefault Set.empty prop $ getConns g node dir++getConns :: Graph -> Node -> Dir -> Map Node (Set Node)+getConns g node dir = Map.findWithDefault Map.empty node $ graphSide dir g++emptyGraph :: Graph+emptyGraph = Graph (Map.empty) (Map.empty) Set.empty++listToGraph :: [Triple] -> Graph+listToGraph = foldr insert emptyGraph++graphToList :: Graph -> [Triple]+graphToList (Graph _ _ triples) = Set.toAscList triples++mergeGraphs :: Op Graph+mergeGraphs g1 g2 = foldr insertVirtual g1 (graphToList g2)++insert :: Triple -> Graph -> Graph+insert t (Graph neg pos triples) =+    insertVirtual t (Graph neg pos $ Set.insert t triples)++insertVirtual :: Triple -> Graph -> Graph+insertVirtual (s,p,o) (Graph neg pos triples) =+    Graph (ins o p s neg) (ins s p o pos) triples where+    ins a b c = Map.alter (Just . Map.alter (Just . Set.insert c . fromMaybe Set.empty) b . fromMaybe Map.empty) a   -- Gack!!! Need to make more readable+    +delete :: Triple -> Graph -> Graph+delete (s,p,o) (Graph neg pos triples) = +    Graph (del o p s neg) (del s p o pos) $ Set.delete (s,p,o) triples where+    del a b c = Map.adjust (Map.adjust (Set.delete c) b) a+    +deleteAll :: Node -> Node -> Graph -> Graph+deleteAll s p g = dels s p os g where+    dels s' p' (o':os') g' = dels s' p' os' (delete (s',p',o') g')+    dels _  _  []       g' = g'+    os = Set.toList $ getAll g s p Pos+    +update :: Triple -> Graph -> Graph+update (s,p,o) g = insert (s,p,o) $ deleteAll s p g+    +triple :: Dir -> (Node,Node,Node) -> Triple+triple Pos (s,p,o) = (s,p,o)+triple Neg (o,p,s) = (s,p,o)++fromNode :: Node -> String+fromNode (URI uri)        = uri+fromNode (PlainLiteral s) = s++rev :: Dir -> Dir+rev Pos = Neg+rev Neg = Pos++mul :: Num a => Dir -> a -> a+mul Pos = id+mul Neg = negate
+ README view
@@ -0,0 +1,81 @@+===================+Fenfire version 0.1+===================+++Introduction+============++Fenfire is a graph-based notetaking system. (We're planning to add a+kitchen sink soon.) It is developed on the channel #fenfire on the+Freenode IRC network.+++The source code is available using Darcs.+    darcs get http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs+++Requirements for compilation+============================++Fenfire source code++Dependencies with known-to-work version numbers:++  ghc    6.6    (The Glorious Glasgow Haskell Compilation System)+  gtk2hs 0.9.11 (A GUI library for Haskell based on Gtk, release candidate ok)+  raptor 1.4.9  (Raptor RDF Parser Toolkit)+  c2hs   0.14.5 (C->Haskell, An Interface Generator for Haskell)+  harp   0.2    (Haskell Regular Patterns, in haskell-src-exts)+  haxml  1.13.2 (Haskell and XML)+  happy  1.15   (The Parser Generator for Haskell)+  alex   2.0.1  (A lexical analyser generator for Haskell)++(Packages in Debian: ghc6 libghc6-gtk-dev libraptor1-dev c2hs libghc6-harp-dev + libghc6-haxml-dev happy alex)+++Running a precompiled binary only requires:+gmp             (The GNU MP Bignum Library)+gtk             (The GIMP Toolkit)+raptor          (Raptor RDF Parser Toolkit)++(Packages in Debian: libgmp3c2 libgtk2.0-0 libraptor1)+++Compiling and running+=====================++Fenfire-hs is packaged using the Haskell Cabal, which means you can use the +following commands to configure, build, and install it to your home directory:++runhaskell Setup.hs configure --user --prefix ~+runhaskell Setup.hs build+runhaskell Setup.hs install++After this, you can start the application like this:++~/bin/fenfire++You will see the application launch with a new graph where you can+start adding your notes using the Edit menu and the included key bindings.++* The current node is highlighted in blue.++* To write into the current node, move to the text box at the bottom+  of the window using Tab or the mouse. After you've finished typing,+  use Tab or the mouse to get back to the graph box.++* Use the Edit menu or the keybindings indicated in the Edit menu to+  - create new nodes+  - mark the current node, or connect the current node to the+    previously marked node(s)+  - break connections between nodes++* Use the arrow keys to move between nodes:+  - Left and Right move to the node directly left or directly right+    from the current node.+  - Up and Down scroll through the nodes connected to the current node.+  - Instead of Left/Right/Up/Down, you can also use j/l/i/comma.++You cannot currently use the mouse to move around the structure.
+ Raptor.chs view
@@ -0,0 +1,222 @@+-- We want the C compiler to always check that types match:+{-# OPTIONS_GHC -fvia-C #-}+module Raptor where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Foreign (Ptr, FunPtr, Storable(pokeByteOff, peekByteOff), allocaBytes,+                nullPtr, castPtr, freeHaskellFunPtr)+import Foreign.C (CString, castCharToCChar, withCString, peekCString, CFile,+                  CSize, CInt, CUChar, CChar)++import System.Posix.IO (stdOutput)+import System.Posix.Types (Fd)+import System.Environment (getArgs)++import Control.Monad (when)+import Data.IORef (modifyIORef, readIORef, newIORef)+import Control.Exception (bracket)++#include <raptor.h>++-- the following three helpers are copied from C2HS.hs:+cToEnum :: (Integral i, Enum e) => i -> e+cToEnum  = toEnum . cIntConv++cFromEnum :: (Enum e, Integral i) => e -> i+cFromEnum  = cIntConv . fromEnum++cIntConv :: (Integral a, Integral b) => a -> b+cIntConv  = fromIntegral+++{#context lib="raptor" prefix="raptor"#}++{#enum raptor_identifier_type as IdType {} deriving (Show)#}++{#enum raptor_uri_source as UriSource {} deriving (Show)#}++{#pointer raptor_uri as URI newtype#}++{#pointer *statement as Statement newtype#}++unStatement :: Statement -> Ptr Statement+unStatement (Statement ptr) = ptr++{#pointer *parser as Parser newtype#}++{#pointer *serializer as Serializer newtype#}++unSerializer :: Serializer -> Ptr Serializer+unSerializer (Serializer ptr) = ptr++type Triple = (Identifier, Identifier, Identifier)++data Identifier = Uri String | Blank String | Literal String+                  deriving (Show)++mkIdentifier :: IO (Ptr ()) -> IO CInt -> IO Identifier+mkIdentifier value format = do+  value' <- value+  format' <- format+  f (castPtr value') (cToEnum format')+    where f v IDENTIFIER_TYPE_RESOURCE = do+                              cstr <- {#call uri_as_string#} (castPtr v) +                              str <- peekCString (castPtr cstr) +                              return $ Uri str+          f v IDENTIFIER_TYPE_PREDICATE = f v IDENTIFIER_TYPE_RESOURCE+          f v IDENTIFIER_TYPE_LITERAL = peekCString v >>= return . Literal+          f v IDENTIFIER_TYPE_ANONYMOUS = peekCString v >>= return . Blank+          f _ i = error $ "Raptor.mkIdentifier: Deprecated type: " ++ show i++getSubject :: Statement -> IO Identifier+getSubject (Statement s) = mkIdentifier ({#get statement->subject#} s)+                                        ({#get statement->subject_type#} s)++getPredicate :: Statement -> IO Identifier+getPredicate (Statement s) = mkIdentifier ({#get statement->predicate#} s)+                                          ({#get statement->predicate_type#} s)++getObject :: Statement -> IO Identifier+getObject (Statement s) = mkIdentifier ({#get statement->object#} s)+                                       ({#get statement->object_type#} s)++withURI :: String -> (Ptr URI -> IO a) -> IO a+withURI string = bracket (withCString string $ {# call new_uri #} . castPtr)+                         {# call free_uri #}++withIdentifier :: (Ptr Statement -> Ptr () -> IO ()) ->+                  (Ptr Statement -> CInt -> IO ()) -> +                  Statement -> Identifier -> IO a -> IO a+withIdentifier setValue setFormat (Statement t) (Uri s) io = do +    setFormat t (cFromEnum IDENTIFIER_TYPE_RESOURCE)+    withURI s $ \uri -> do+        setValue t (castPtr uri)+        io+withIdentifier setValue setFormat (Statement t) (Literal s) io = do+    setFormat t (cFromEnum IDENTIFIER_TYPE_LITERAL)+    withCString s $ \str -> do+        setValue t (castPtr str)+        io+withIdentifier _ _ _ i _ =+    error $ "Raptor.setIdentifier: unimplemented: " ++ show i++withSubject = withIdentifier {# set statement->subject #}+                             {# set statement->subject_type #} ++withPredicate = withIdentifier {# set statement->predicate #}+                               {# set statement->predicate_type #}++withObject = withIdentifier {# set statement->object #}+                            {# set statement->object_type #}++type Handler a = Ptr a -> Statement -> IO ()+foreign import ccall "wrapper"+   mkHandler :: (Handler a) -> IO (FunPtr (Handler a))++foreign import ccall "raptor.h raptor_init" initRaptor :: IO ()+foreign import ccall "raptor.h raptor_new_parser" new_parser :: Ptr CChar -> IO (Ptr Parser)+foreign import ccall "raptor.h raptor_set_statement_handler" set_statement_handler :: Ptr Parser -> Ptr a -> FunPtr (Handler a) -> IO () +foreign import ccall "raptor.h raptor_uri_filename_to_uri_string" uri_filename_to_uri_string :: CString -> IO CString+foreign import ccall "raptor.h raptor_new_uri" new_uri :: Ptr CChar -> IO (Ptr URI)+foreign import ccall "raptor.h raptor_uri_copy" uri_copy :: Ptr URI -> IO (Ptr URI)+foreign import ccall "raptor.h raptor_parse_file" parse_file :: Ptr Parser -> Ptr URI -> Ptr URI -> IO ()++foreign import ccall "raptor.h raptor_print_statement_as_ntriples" print_statement_as_ntriples :: Statement -> Ptr CFile -> IO ()++foreign import ccall "stdio.h fdopen" fdopen :: Fd -> CString -> IO (Ptr CFile)+foreign import ccall "stdio.h fputc" fputc :: CChar -> Ptr CFile -> IO ()++foreign import ccall "string.h memset" c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)+++-- | Serialize the given triples into a file with the given filename+--+triplesToFilename :: [Triple] -> String -> IO ()+triplesToFilename triples filename = do +  initRaptor++  serializer <- withCString "ntriples" {# call new_serializer #}+  when (unSerializer serializer == nullPtr) $ fail "serializer is null"+  +  withCString filename $ {# call serialize_start_to_filename #} serializer++  allocaBytes {# sizeof statement #} $ \ptr -> do+    let t = Statement ptr+    flip mapM_ triples $ \(s,p,o) -> do+      c_memset ptr 0 {# sizeof statement #}+      withSubject t s $ withPredicate t p $ withObject t o $ do+        {# call serialize_statement #} serializer t+        return ()+  {# call serialize_end #} serializer+  {# call free_serializer #} serializer+  {# call finish #}++-- | Parse a file with the given filename into triples+--+filenameToTriples :: String -> IO [Triple]+filenameToTriples filename = do +  result <- newIORef []++  initRaptor+  let suffix = reverse $ takeWhile (/= '.') $ reverse filename+      parsertype = case suffix of "turtle" -> "turtle"+                                  _        -> "guess"+  rdf_parser <- withCString parsertype new_parser +  when (rdf_parser == nullPtr) $ fail "parser is null"+  handler <- mkHandler $ \_user_data triple -> do+    s <- getSubject triple+    p <- getPredicate triple+    o <- getObject triple+    modifyIORef result ((s,p,o):)++  set_statement_handler rdf_parser nullPtr handler+  uri_str <- withCString filename uri_filename_to_uri_string+  uri <- new_uri uri_str+  base_uri <- uri_copy uri+  parse_file rdf_parser uri base_uri++  {# call free_parser #} (Parser rdf_parser)+  freeHaskellFunPtr handler+  {# call free_uri #} uri+  {# call free_uri #} base_uri+  {# call free_memory #} (castPtr uri_str)++  {# call finish #}+  readIORef result++-- The following print_triple and filenameToStdout are an incomplete and +-- improved translation of raptor examples/rdfprint.c:++print_triple :: Ptr CFile -> Handler a+print_triple outfile _user_data s = do print_statement_as_ntriples s outfile+                                       fputc (castCharToCChar '\n') outfile++filenameToStdout :: String -> IO ()+filenameToStdout filename = do+  outfile <- withCString "w" $ fdopen stdOutput++  initRaptor+  rdf_parser <- withCString "guess" new_parser +  when (rdf_parser == nullPtr) $ fail "parser is null"+  mkHandler (print_triple outfile) >>= set_statement_handler rdf_parser nullPtr+  uri <- withCString filename uri_filename_to_uri_string >>= new_uri+  base_uri <- uri_copy uri+  parse_file rdf_parser uri base_uri+  return ()
+ Setup.hs view
@@ -0,0 +1,43 @@+#!/usr/bin/env runhaskell+import Control.Monad (when)+import Distribution.PreProcess+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils (rawSystemVerbose, dieWithLocation)+import System.Cmd (system)+import System.Directory (getModificationTime, doesFileExist)++main = defaultMainWithHooks hooks+hooks = defaultUserHooks { hookedPreProcessors = [trhsx, c2hs] }++trhsx :: PPSuffixHandler+trhsx = ("fhs", f) where+    f buildInfo localBuildInfo inFile outFile verbose = do+        when (verbose > 3) $+            putStrLn ("checking that preprocessor is up-to-date")+        let [pIn, pOut] = ["Preprocessor/Hsx/Parser."++s | s <- ["ly","hs"]]+        exists <- doesFileExist pOut+        runHappy <- if not exists then return True else do+            [tIn, tOut] <- mapM getModificationTime [pIn, pOut]+            return (tIn > tOut)+        when runHappy $ system ("happy "++pIn) >> return ()+        system ("ghc --make Preprocessor/Main.hs -o preprocessor")++        when (verbose > 0) $+            putStrLn ("preprocessing "++inFile++" to "++outFile)+        writeFile outFile ("-- GENERATED file. Edit the ORIGINAL "++inFile+++                           " instead.\n")+        system ("./preprocessor "++inFile++" >> "++outFile)+        +c2hs :: PPSuffixHandler+c2hs = ("chs", f) where+    f buildInfo localBuildInfo inFile outFile verbose = do+        when (verbose > 0) $+            putStrLn $ "preprocess "++inFile++" to "++outFile+        maybe (dieWithLocation inFile Nothing "no c2hs available")+              (\c2hs -> rawSystemVerbose verbose c2hs+                            ["--cppopts", "-D\"__attribute__(A)= \"", +                             "-o", outFile, inFile])+              (withC2hs localBuildInfo) +            +
+ Utils.hs view
@@ -0,0 +1,163 @@+-- For (instance MonadReader w m => MonadReader w (MaybeT m)) in GHC 6.6:+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+module Utils where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Control.Applicative+import Control.Monad+import Control.Monad.List+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans+import Control.Monad.Writer (WriterT(..), MonadWriter(..), execWriterT)++import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))++import qualified System.Time+++-- just what the rhs says, a function from a type to itself+type Endo a = a -> a++type EndoM m a = a -> m a+type Op a      = a -> a -> a++type Time     = Double -- seconds since the epoch+type TimeDiff = Double -- in seconds+++avg :: Fractional a => Op a+avg x y = (x+y)/2+++maybeReturn :: MonadPlus m => Maybe a -> m a+maybeReturn = maybe mzero return++returnEach :: MonadPlus m => [a] -> m a+returnEach = msum . map return++maybeDo :: Monad m => Maybe a -> (a -> m ()) -> m ()+maybeDo m f = maybe (return ()) f m+++getTime :: IO Time+getTime = do (System.Time.TOD secs picosecs) <- System.Time.getClockTime+             return $ fromInteger secs + fromInteger picosecs / (10**(3*4))+             +             +(&) :: Monoid m => m -> m -> m+(&) = mappend+++funzip :: Functor f => f (a,b) -> (f a, f b)+funzip x = (fmap fst x, fmap snd x)++ffor :: Functor f => f a -> (a -> b) -> f b+ffor = flip fmap++forM_ :: Monad m => [a] -> (a -> m b) -> m ()+forM_ = flip mapM_++forA2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c+forA2 x y f = liftA2 f x y++forA3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d+forA3 a b c f = liftA3 f a b c+++newtype Comp f g a = Comp { fromComp :: f (g a) }++instance (Functor f, Functor g) => Functor (Comp f g) where+    fmap f (Comp m) = Comp (fmap (fmap f) m)+    +instance (Applicative f, Applicative g) => Applicative (Comp f g) where+    pure = Comp . pure . pure+    Comp f <*> Comp x = Comp $ forA2 f x (<*>)+++newtype BreadthT m a = BreadthT { runBreadthT :: WriterT [BreadthT m ()] m a }+    +scheduleBreadthT :: Monad m => BreadthT m a -> BreadthT m ()+scheduleBreadthT m = BreadthT $ tell [m >> return ()]++execBreadthT :: Monad m => BreadthT m a -> m ()+execBreadthT m = do rest <- execWriterT (runBreadthT m)+                    when (not $ null rest) $ execBreadthT (sequence_ rest)++instance Monad m => Monad (BreadthT m) where+    return  = BreadthT . return+    m >>= f = BreadthT (runBreadthT m >>= runBreadthT . f)+    +instance MonadTrans BreadthT where+    lift = BreadthT . lift+    +instance MonadState s m => MonadState s (BreadthT m) where+    get = lift $ get+    put = lift . put+    +instance MonadWriter w m => MonadWriter w (BreadthT m) where+    tell = lift . tell+    listen m = BreadthT $ WriterT $ do+        ((x,w),w') <- listen $ runWriterT (runBreadthT m)+        return ((x,w'),w)+    pass m = BreadthT $ WriterT $ pass $ do+        ((x,f),w) <- runWriterT (runBreadthT m)+        return ((x,w),f)+++newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++instance Monad m => Monad (MaybeT m) where+    return x = MaybeT $ return (Just x)+    m >>= f  = MaybeT $ do x <- runMaybeT m+                           maybe (return Nothing) (runMaybeT . f) x+    fail _   = mzero+    +instance MonadTrans MaybeT where+    lift m = MaybeT $ do x <- m; return (Just x)++instance Monad m => MonadPlus (MaybeT m) where+    mzero = MaybeT $ return Nothing+    mplus m n = MaybeT $ do+        x <- runMaybeT m; maybe (runMaybeT n) (return . Just) x+        +instance MonadReader r m => MonadReader r (MaybeT m) where+    ask = lift ask+    local f m = MaybeT $ local f (runMaybeT m)+    +instance MonadWriter w m => MonadWriter w (MaybeT m) where+    tell = lift . tell+    listen m = MaybeT $ do (x,w) <- listen $ runMaybeT m+                           return $ maybe Nothing (\x' -> Just (x',w)) x+    pass m = MaybeT $ pass $ do +        x <- runMaybeT m; return $ maybe (Nothing,id) (\(y,f) -> (Just y,f)) x++callMaybeT :: Monad m => MaybeT m a -> MaybeT m (Maybe a)+callMaybeT = lift . runMaybeT+++instance MonadWriter w m => MonadWriter w (ListT m) where+    tell = lift . tell+    listen m = ListT $ do (xs,w) <- listen $ runListT m+                          return [(x,w) | x <- xs]+    pass m = ListT $ pass $ do -- not ideal impl, but makes 'censor' work+        ps <- runListT m+        return $ if null ps then ([], id) else (map fst ps, snd (head ps))
+ VobTest.fhs view
@@ -0,0 +1,173 @@+module VobTest where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Utils+import Cairo+import Vobs+import qualified Data.List+import Data.Map (fromList)+import Data.Maybe (fromJust)+import Data.IORef+import Data.Monoid hiding (Endo)+import Control.Applicative+import Control.Monad.State+import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)+import System.Environment (getArgs)+++type Info = (String, Double, Double)+type Data = [(String,[Info])]++--myVob1 :: Vob (String, Int)+--myVob1 = keyVob "1" $ rectBox $ pad 5 $ multiline False 20 "Hello World!"++myVob2 :: Vob (String, Int)+myVob2 = mempty --keyVob "2" $ rectBox $ label "Foo bar baz"++{-+myScene1 :: String -> Data -> Vob (String, Int)+myScene1 t d = mconcat [ stroke $ line (center @@ "1") (center @@ "2"),+                         translate #50 #100 $ myVob2,+                         translate #250 #150  $ myVob1 t d ]+-}++myScene2 :: String -> Data -> Vob (String, Int)+myScene2 t d = translate #350 #400 $ rotate #(-pi/15) $ scale #1.5 $ +    changeSize (\(w,h) -> (w-30, h)) $ myVob1 t d+    +    +myVob1 :: String -> Data -> Vob (String, Int)+myVob1 t d = keyVob ("vob",1) $ {-ownSize $ resize (250, 250) $-} +        pad 20 $ daisy t info where+    info = fromJust (Data.List.lookup t d)+++setSize :: Cx (String, Int) Double -> Cx (String, Int) Double -> +           Endo (Vob (String, Int))+setSize w h = cxLocalR #(!cxMatrix, (!w, !h))++daisy :: String -> [(String, Double, Double)] -> Vob (String, Int)+daisy target distractors = +      mconcat [withDash #[4] #0 $+                   stroke (circle center #(inner + !w * radius))+              | radius <- [0, 1/4, 9/16, 1]]+    & mconcat [(translateTo center $+                   rotate #(((fromIntegral i)::Double) * angle) $+                       translate #inner #0 $ setSize w h $+                           daisyLeaf (distractors !! i))+               & translateTo (center @@ (name i,-1)) +                             (centerVob $ label $ name i)+              | i <- [0..n-1]]+    & translateTo center (centerVob $ label target)+  where+    inner = 20.0 :: Double+    size = #(uncurry min !cxSize)+    w = #((!size - inner)/2); h = #(!w / 20)+    n = length distractors+    name i = case distractors !! i of (r,_,_) -> r+    angle :: Double+    angle = (2.0*pi) / fromIntegral n+++likelihood correct total p = (p ** correct) * ((1 - p) ** (total - correct))++fractions :: Int -> [Double]+fractions n = [fromIntegral i / fromIntegral n | i <- [0..n]]++normalize :: [Double] -> [Double]+normalize xs = map (/s) xs where s = sum xs++accumulate :: [Double] -> [Double]+accumulate = scanl (+) 0++table :: Int -> (Double -> Double) -> [Double]+table steps f = [f (fromIntegral i / len) | i <- [0..steps-1]] where+    len = fromIntegral (steps - 1)++{-+untable :: [Double] -> (Double -> Double)+untable vals = f where+    nvals = fromIntegral (length vals) :: Double; offs = 1 / nvals+    f x = interpolate fract (vals !! idx) (vals !! idx+1) where+        idx = floor (x / offs); fract = x/offs - fromIntegral idx+-}+        +invert :: [Double] -> (Double -> Double)+invert ys = \y -> if y < head ys then 0 else val y 0 ys where+    val v i (x:x':xs) | x <= v && v < x' = i + offs * (v-x) / (x'-x)+                      | otherwise        = val v (i+offs) (x':xs)+    val _ _ _                            = 1+    offs = 1 / fromIntegral (length ys - 1) :: Double++denormalize :: [Double] -> [Double]+denormalize xs = map (* len) xs where len = fromIntegral $ length xs++daisyLeaf :: (String, Double, Double) -> Vob (String, Int)+daisyLeaf (name, correct, total) =+    withColor #color (fill shape) & stroke shape & mconcat pointVobs+    & translateTo (anchor #(correct/total) #0)+                  (ownSize $ keyVob (name,-1) mempty)+  where+    n = 40+    fracts = fractions n+    pointsA = zip fracts ys where+        ys = denormalize $ normalize [likelihood correct total p | p <- fracts]+    pointsB = zip xs ys where+        xs = map f fracts+        f = invert $ accumulate $ normalize [likelihood correct total p | p <- fracts]+        ys = denormalize $ normalize [likelihood correct total p | p <- xs]+    points' = pointsB+    points = points' ++ reverse (map (\(x,y) -> (x,-y)) points')+    pointKeys = [(name, i) | i <- [0..2*n+1]]+    pointVobs = flip map (zip points pointKeys) $ \((x,y),k) -> +        translateTo (anchor #x #y) (keyVob k mempty)+    path = [anchor #0 #0 @@ k | k <- pointKeys]+    shape = moveTo (head path) & mconcat (map lineTo $ tail path) & closePath+    color = interpolate (correct/total) (Color 1 0 0 0.5) (Color 0 1 0 0.5)++main = do +    args <- getArgs+    let fname = if length args == 0 then "DaisyData.txt" else head args+    testdata <- readFile fname >>= return . (read :: String -> Data)++    initGUI+    window <- windowNew+    windowSetTitle window "Vob test"+    windowSetDefaultSize window 700 400++    stateRef <- newIORef (fst $ head testdata)++    let view state    = myVob1 state testdata+        handle _event = do t <- get; let ts = map fst testdata+                           let i = fromJust $ Data.List.elemIndex t ts+                               i' = if i+1 >= length ts then 0 else i+1+                           put (ts !! i')+                           setInterp True++    (canvas, _updateCanvas, _canvasAction) <- vobCanvas stateRef view handle +                                                        (const $ return ()) +                                                        (const $ return ()) +                                                        lightGray 3++    set window [ containerChild := canvas ]+    +    onDestroy window mainQuit+    widgetShowAll window+    mainGUI
+ Vobs.fhs view
@@ -0,0 +1,391 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+module Vobs where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Utils++import Cairo++import Data.IORef+import System.IO.Unsafe (unsafePerformIO)+import qualified System.Time++import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Trans (liftIO, MonadIO)++import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)+import qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))+import qualified Graphics.Rendering.Cairo.Matrix as Matrix+import Graphics.UI.Gtk.Cairo++import Data.List (intersect)+import Data.Map (Map, keys, fromList, toList, insert, empty)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid (Monoid(mempty, mappend))++import Control.Monad (when)+import Control.Monad.State+import Control.Monad.Reader+++type Scene k  = Map k (Maybe (Matrix, Size))+data Vob k    = Vob { defaultSize :: Size,+                      vobScene :: RenderContext k -> Scene k,+                      renderVob :: RenderContext k -> Render () }++type Cx k     = MaybeT (Reader (RenderContext k))++runCx :: RenderContext k -> Cx k a -> Maybe a+runCx cx m = runReader (runMaybeT m) cx++data RenderContext k = RenderContext {+    rcRect :: Rect, rcScene :: Scene k, rcFade :: Double,+    rcFgColor :: Color, rcBgColor :: Color, rcFadeColor :: Color }+    +rcMatrix = fst . rcRect; rcSize = snd . rcRect+    +type View s k  = s -> Vob k+type Handler e s = e -> HandlerAction s++type HandlerAction s = StateT s (StateT (Bool, Bool) IO) ()+++instance Ord k => Monoid (Vob k) where+    mempty = Vob (0,0) (const Map.empty) (const $ return ())+    mappend (Vob (w1,h1) sc1 r1) (Vob (w2,h2) sc2 r2) = Vob (w,h) sc r where+        (w,h) = (max w1 w2, max h1 h2)+        sc cx = Map.union (sc1 cx) (sc2 cx)+        r cx = r1 cx >> r2 cx+        +instance Functor (Cx k) where fmap = liftM+instance Applicative (Cx k) where +    pure = return+    (<*>) = ap++instance Ord k => Cairo (Cx k) (Vob k) where+    cxAsk = asks rcRect+    +    cxLocal rect m = do rect' <- rect; local (\cx -> cx { rcRect = rect' }) m++    cxWrap f (Vob size sc ren) =+        Vob size sc $ \cx -> maybeDo (runCx cx $ f $ ren cx) id+        +    cxLocalR rect (Vob size sc ren) = Vob size+            (\cx -> let msc = liftM sc (upd cx)+                    in Map.mapWithKey (\k _ -> msc >>= (Map.! k)) (sc cx))+            (\cx -> maybe (return ()) ren (upd cx))+        where upd cx = do rect' <- runCx cx rect+                          return $ cx { rcRect = rect' }+    ++defaultWidth  (Vob (w,_) _ _) = w+defaultHeight (Vob (_,h) _ _) = h+++setInterp :: Bool -> HandlerAction s+setInterp interp = lift $ modify $ \(_,handled) -> (interp, handled)++unhandledEvent :: HandlerAction s+unhandledEvent = lift $ modify $ \(interp,_) -> (interp, False)++runHandler handleEvent state event = do+    (((), state'), (interpolate', handled)) <- +        runStateT (runStateT (handleEvent event) state) (False, True)+    return (state',interpolate',handled)+++(@@) :: Ord k => Cx k a -> k -> Cx k a   -- pronounce as 'of'+(@@) x key = do cx <- ask+                rect <- maybeReturn =<< Map.lookup key (rcScene cx)+                local (\_ -> cx { rcRect = rect }) x+++changeSize :: Ord k => Endo Size -> Endo (Vob k)+changeSize f vob = vob { defaultSize = f $ defaultSize vob }++changeContext :: Ord k => Endo (RenderContext k) -> Endo (Vob k)+changeContext f (Vob s sc r) = Vob s (sc . f) (r . f)++changeRect :: Ord k => Endo Rect -> Endo (Vob k)+changeRect f = changeContext (\cx -> cx { rcRect = f $ rcRect cx })++ownSize :: Ord k => Endo (Vob k)+ownSize vob = changeRect (\(m,_) -> (m, defaultSize vob)) vob++invisibleVob :: Ord k => Endo (Vob k)+invisibleVob = cxWrap (const mempty)+    ++comb :: Size -> (RenderContext k -> Vob k) -> Vob k+comb size f = +    Vob size (\cx -> vobScene (f cx) cx) (\cx -> renderVob (f cx) cx)++renderable :: Ord k => Size -> Render () -> Vob k+renderable size ren = Vob size (const Map.empty) $ \cx -> do+    do C.save; C.transform (rcMatrix cx); ren; C.restore+++keyVob :: Ord k => k -> Endo (Vob k)+keyVob key vob = vob { +    vobScene = \cx -> Map.insert key (Just $ rcRect cx) (vobScene vob cx),+    renderVob = \cx -> +        maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->+            renderVob vob $ cx { rcRect = rect } }+        ++rectBox :: Ord k => Endo (Vob k)+rectBox vob = useBgColor (fill extents) & clip extents vob & +              useFgColor (stroke extents)+        ++pangoContext :: PangoContext+pangoContext = unsafePerformIO $ do+    context <- cairoCreateContext Nothing+    desc    <- contextGetFontDescription context+    fontDescriptionSetFamily desc "Sans"+    fontDescriptionSetSize   desc (fromInteger 10)+    contextSetFontDescription context desc+    return context+    ++label :: Ord k => String -> Vob k+label s = unsafePerformIO $ do +    layout  <- layoutText pangoContext s+    (PangoRectangle _ _ w1 h1, PangoRectangle _ _ w2 h2) +        <- layoutGetExtents layout+    let w = max w1 w2; h = max h1 h2+    return $ renderable (realToFrac w, realToFrac h) $ showLayout layout+    +multiline :: Ord k => Bool -> Int -> String -> Vob k+multiline useTextWidth widthInChars s = unsafePerformIO $ do +    layout  <- layoutText pangoContext s+    layoutSetWrap layout WrapPartialWords+    desc    <- contextGetFontDescription pangoContext+    lang    <- languageFromString s+    (FontMetrics {approximateCharWidth=cw, ascent=ascent', descent=descent'})+        <- contextGetMetrics pangoContext desc lang+    let w1 = fromIntegral widthInChars * cw+        h1 = ascent' + descent'+    layoutSetWidth layout (Just w1)+    (PangoRectangle _ _ w2 h2, PangoRectangle _ _ w3 h3) +        <- layoutGetExtents layout+    let w = if useTextWidth then max w2 w3 else w1+        h = maximum [h1, h2, h3]+    return $ renderable (realToFrac w, realToFrac h) $ showLayout layout++                          +fadedColor :: Ord k => Endo (Cx k Color)+fadedColor c = liftM3 interpolate (asks rcFade) (asks rcFadeColor) c++setFgColor :: Ord k => Color -> Endo (Vob k)+setFgColor c = changeContext $ \cx -> cx { rcFgColor = c }++setBgColor :: Ord k => Color -> Endo (Vob k)+setBgColor c = changeContext $ \cx -> cx { rcBgColor = c }++useFgColor :: Ord k => Endo (Vob k)+useFgColor = withColor (fadedColor $ asks rcFgColor)++useBgColor :: Ord k => Endo (Vob k)+useBgColor = withColor (fadedColor $ asks rcBgColor)++useFadeColor :: Ord k => Endo (Vob k)+useFadeColor = withColor (asks rcFadeColor)++fade :: Ord k => Double -> Endo (Vob k)+fade a = changeContext $ \cx -> cx { rcFade = rcFade cx * a }+++centerVob :: Ord k => Endo (Vob k)+centerVob vob = translate (pure (-w/2)) (pure (-h/2)) vob+    where (w,h) = defaultSize vob++               +pad4 :: Ord k => Double -> Double -> Double -> Double -> Endo (Vob k)+pad4 x1 x2 y1 y2 vob = +    changeSize (const (x1+w+x2, y1+h+y2)) $+        changeRect (\(m,(w',h')) -> (f m, (w'-x1-x2, h'-y1-y2))) vob+    where (w,h) = defaultSize vob; f = Matrix.translate x1 y1+    +pad2 :: Ord k => Double -> Double -> Endo (Vob k)+pad2 x y   = pad4 x x y y++pad :: Ord k => Double -> Endo (Vob k)+pad pixels = pad2 pixels pixels+    +    +class Interpolate a where+    interpolate :: Double -> Op a+    +instance Interpolate Double where+    interpolate fract x y = (1-fract)*x + fract*y+    +instance Interpolate Color where+    interpolate fract (Color r g b a) (Color r' g' b' a') =+        Color (i r r') (i g g') (i b b') (i a a') where+            i = interpolate fract++instance Interpolate Matrix where+    interpolate fract (Matrix u v w x y z) (Matrix u' v' w' x' y' z') =+        Matrix (i u u') (i v v') (i w w') (i x x') (i y y') (i z z') where+            i = interpolate fract++interpolateScene :: Ord k => Double -> Op (Scene k)+interpolateScene fract sc1 sc2 =+    fromList [(key, liftM2 f (sc1 Map.! key) (sc2 Map.! key)) +             | key <- interpKeys] where+        interpKeys = intersect (keys sc1) (keys sc2)+        f (m1,(w1,h1)) (m2,(w2,h2)) = (i m1 m2, (i w1 w2, i h1 h2))+        i x y = interpolate fract x y+             ++isInterpUseful :: Ord k => Scene k -> Scene k -> Bool             +isInterpUseful sc1 sc2 = +    not $ all same [(sc1 Map.! key, sc2 Map.! key) | key <- interpKeys]+    where same (a,b) = all (\d -> abs d < 5) $ zipWith (-) (values a) (values b)+          values (Just (Matrix a b c d e f, (w,h))) = [a,b,c,d,e,f,w,h]+          values Nothing = error "shouldn't happen"+          interpKeys = intersect (getKeys sc1) (getKeys sc2)+          getKeys sc = [k | k <- keys sc, isJust (sc Map.! k)]+          +instance Show Modifier where+    show Shift = "Shift"+    show Control = "Control"+    show Alt = "Alt"+    show Apple = "Apple"+    show Compose = "Compose"++timeDbg :: MonadIO m => String -> Endo (m ())+timeDbg s act | False     = do out s; act; out s+              | otherwise = act+    where out t = liftIO $ do time <- System.Time.getClockTime+                              putStrLn $ s ++ " " ++ t ++ "\t" ++ show time+       ++linearFract :: Double -> (Double, Bool)+linearFract x = if (x<1) then (x,True) else (1,False)++bounceFract :: Double -> (Double, Bool)+bounceFract x = (y,cont) where     -- ported from AbstractUpdateManager.java+    x' = x + x*x+    y = 1 - cos (2 * pi * n * x') * exp (-x' * r)+    cont = -(x + x*x)*r >= log 0.02+    (n,r) = (0.4, 2)++++type Anim a = Time -> (Scene a, Bool)  -- bool is whether to re-render++interpAnim :: Ord a => Time -> TimeDiff -> Scene a -> Scene a -> Anim a+interpAnim startTime interpDuration sc1 sc2 time =+    if continue then (interpolateScene fract sc1 sc2, True) else (sc2, False)+    where (fract, continue) = bounceFract ((time-startTime) / interpDuration)+    +noAnim scene = const (scene, False)+    ++vobCanvas :: Ord b => IORef a -> View a b -> Handler Event a -> +                      Handler c a -> (a -> IO ()) -> Color -> TimeDiff ->+                      IO (DrawingArea, Bool -> IO (), c -> IO Bool)+vobCanvas stateRef view eventHandler actionHandler stateChanged +          bgColor animTime = do+    canvas <- drawingAreaNew+    +    widgetSetCanFocus canvas True+    +    animRef <- newIORef (mempty, Map.empty, noAnim Map.empty)+    +    let getWH = do (cw, ch) <- drawingAreaGetSize canvas+                   return (fromIntegral cw, fromIntegral ch)+                   +        getVob = do state <- readIORef stateRef+                    return $ useFadeColor paint & view state+                    +        getRenderContext sc = do +            size <- getWH; return $ RenderContext {+                rcScene=sc, rcRect=(Matrix.identity, size), rcFade=1,+                rcFgColor=black, rcBgColor=white, rcFadeColor=bgColor }+                   +        updateAnim interpolate' = mdo+	    (vob,scene,_) <- readIORef animRef+            vob' <- getVob++            rc' <- getRenderContext scene'+	    let scene' = vobScene vob' rc'+	        +	    time <- scene' `seq` getTime+	    +	    let anim' = if interpolate' && isInterpUseful scene scene'+                        then interpAnim time animTime scene scene'+	                else noAnim scene'++	    writeIORef animRef (vob', scene', anim')+	+	    widgetQueueDraw canvas++        handle handler event = do+            state <- readIORef stateRef++            (state', interpolate', handled) <- +                runHandler handler state event++            when handled $ do writeIORef stateRef state'+                              stateChanged state'+                              updateAnim interpolate'++            return handled++        handleEvent = handle eventHandler++        handleAction = handle actionHandler++    onRealize canvas $ mdo vob <- getVob; rc <- getRenderContext scene+                           let scene = vobScene vob rc+                           writeIORef animRef (vob, scene, noAnim scene)+    +    onConfigure canvas $ \_event -> do updateAnim False; return True++    onKeyPress canvas $ \event -> do+        let Key {eventModifier=mods,eventKeyName=key,eventKeyChar=char} = event+        putStrLn $ show mods++" "++key++" ("++show char++")"++        handleEvent event++    onButtonPress canvas $ \(Button {}) -> do+        widgetGrabFocus canvas+        return True+    +    onExpose canvas $ \(Expose {}) -> do+        drawable <- drawingAreaGetDrawWindow canvas+        +        (vob, _, anim) <- readIORef animRef;  time <- getTime+        let (scene, rerender) = anim time+        rc <- getRenderContext scene+        +        renderWithDrawable drawable $ timeDbg "redraw" $ renderVob vob rc+	+	if rerender then widgetQueueDraw canvas else return ()++        return True+        +    return (canvas, updateAnim, handleAction)
+ _darcs/checkpoints/20070213183146-0f16d-7b9215f92f7d75ad659a4968ae9c55a9b75de4f7.gz view

binary file changed (absent → 96112 bytes)

+ _darcs/checkpoints/inventory view
@@ -0,0 +1,2 @@+[TAG fenfire-0.1+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070213183146]
+ _darcs/inventories/20070203131731-bf390-cc846d14f59043804156af4105fc7fce2c4781fb.gz view
@@ -0,0 +1,378 @@+["Hello, world"+benja.fallenstein@gmail.com**20061213213846] +[add clipvob+Benja Fallenstein <benja.fallenstein@gmail.com>**20061213214452] +[code for gzz 0.6-style vob scenes & their interpolation+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214000714] +[functions to change the size request of a vob+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214000826] +[animation+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214003551] +[store widths and heights in vobscenes and pass them to vobs' draw methods+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214003729] +[merge+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214004522] +[clearer variable names in 'interpolate'+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214010957] +[key press handler stub+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214020350] +[not-yet-working vanishing view code+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214030252] +[simple makefile, doesn't work for both targets+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214033414] +[We get signal: Try using functional reactive programming for the animations+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214193744] +[fixes and test data for vanishingView+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214194351] +[test main for vanishingView+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214194458] +[merge+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214194549] +[a fix to "get"+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214201507] +[fix tuukka's fix :-)+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214203246] +[make compile with changes to Vobs+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214203301] +[visual twids+Benja Fallenstein <benja.fallenstein@gmail.com>**20061214204904] +[schedule redraw to next change of signal+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061214223514] +[key binding hack for browsing+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215001216] +[more test data, fixes, tweaks+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215001348] +[unfinished merge of Fenfire state system with vobMain+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215165725] +[make the wheel rotate the way I'm used to :)+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215165859] +[empty stream and constant signal constructors in Signals+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215165922] +[yay, signal-based fenfire! :-)+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215172808] +[don't have updateable Streams any more, only Signals (we didn't use Stream anywhere except in Signals yet); make Signal into a Monad+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215183336] +[simplify streamJoin2+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215185558] +[minor cleanup: remove Fenfire.oldmain, move vob test code to VobTest.hs+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215193216] +[die on key press q, don't die on unknown key presses+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215200047] +[rename target vobs as vobtest, depend on all *.hs files+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215200133] +[get rid of warnings+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215200809] +[limit rotation to height+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215212004] +[turn on ghc warnings in makefile, get rid of warnings in code+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215212319] +[make vob's sizes (Double, Double) instead of Render (Double, Double)+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215211531] +[merge+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215213606] +[twids to label: use the layout for computing the text extents also to render the text+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215212846] +[get rid of RScene, too, the remaining place where the render monad was used but shouldn't be+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215212949] +[merge+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061215215027] +[fix vanishingView to use the actual vob sizes, now that we don't need the render monad to *get* the sizes any longer+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215214332] +[fix conflict+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215215302] +[fix+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215220133] +[fix+Benja Fallenstein <benja.fallenstein@gmail.com>**20061215221221] +[get rid of the Signals module which seems to only have been a complication at this point+Benja Fallenstein <benja.fallenstein@gmail.com>**20061216225215] +[something animates. it's slow, but I'm not sure whether it's a bug or my computer+Benja Fallenstein <benja.fallenstein@gmail.com>**20061216234424] +[add to Makefile targets to run the binaries+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061216235700] +[use PangoRectangle with realToFrac+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061216235820] +[fix warnings+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061217000406] +[port bouncing animation from java updatemanager+Benja Fallenstein <benja.fallenstein@gmail.com>**20061220205910] +[use rdfs:label as text property when available; don't show rdfs:label connections+Benja Fallenstein <benja.fallenstein@gmail.com>**20061220213347] +[add entering and backspacing text. quitting is alt-q now. there's no text cursor yet; all editing happens at the end of the node.+Benja Fallenstein <benja.fallenstein@gmail.com>**20061220220649] +[multiline text+Benja Fallenstein <benja.fallenstein@gmail.com>**20061221154846] +[use smaller font; always make nodes at least the font metrics' height+Benja Fallenstein <benja.fallenstein@gmail.com>**20061221161142] +[use the maximum of the two rectangles returned by layoutGetExtents for multiline text vobs+Benja Fallenstein <benja.fallenstein@gmail.com>**20061221161927] +[break too long words in multiline+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061221163404] +[don't interpolate after text editing+Benja Fallenstein <benja.fallenstein@gmail.com>**20061221162944] +[make vobtest compile+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061221164600] +[add rgbaColor+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061221170010] +[use x' as meant in bounceFract+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061221174520] +[fix warnings+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061221174708] +[move test graph back to module level+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061221235600] +[make Fenfire usable in ghci once again+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061222000822] +[extend names of lambda _ variables+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061222001424] +[interpolate key presses, don't interpolate if vobs don't move+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061222023957] +[fix interpolationNull and rename it to the traditional isInterpUseful+benja.fallenstein@gmail.com**20061222133024] +[turn vobMain into a function returning a widget, so that we can combine it with other widgets+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222165131] +[use a TextView widget for text editing+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222193305] +[oops, make compile again+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222193841] +[tell Gtk whether we handled an event, so that key events we handled aren't also interpreted by Gtk too+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222200731] +[make 'q' quit again in Fenfire when the vob canvas has focus+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222200914] +[a bit of code simplification+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222211243] +[more small code simplification+Benja Fallenstein <benja.fallenstein@gmail.com>**20061222214115] +[fix the compiler warning+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061222214958] +[more code twids+Benja Fallenstein <benja.fallenstein@gmail.com>**20061223010123] +[finally, a readable vanishing view+Benja Fallenstein <benja.fallenstein@gmail.com>**20061225192016] +[down arrow shouldn't change focus even in case of no rotation+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061226001043] +[use monad transformers in vanishing view plumbing+Benja Fallenstein <benja.fallenstein@gmail.com>**20061226160359] +[vanishingview plumbing code twids+Benja Fallenstein <benja.fallenstein@gmail.com>**20061226173512] +[try generalizing types as tuukkah suggested+Benja Fallenstein <benja.fallenstein@gmail.com>**20061226185627] +[make functions return Maybe again instead of MonadPlus, I think it makes more sense; rename returnList to returnEach and returnMaybe to maybeReturn+Benja Fallenstein <benja.fallenstein@gmail.com>**20061227093653] +[implement the vob system discussed on IRC yesterday+Benja Fallenstein <benja.fallenstein@gmail.com>**20061227153044] +[Connections!+Benja Fallenstein <benja.fallenstein@gmail.com>**20061227153106] +[run the view before getting the animation start time, so that we don't have an ugly jump if creating the view takes some time+Benja Fallenstein <benja.fallenstein@gmail.com>**20061227154448] +[fix the bug that allowed the user to move to some wrong rotations+Benja Fallenstein <benja.fallenstein@gmail.com>**20061227155850] +[scaling when depth increases+Benja Fallenstein <benja.fallenstein@gmail.com>**20061230110209] +[depth fading+Benja Fallenstein <benja.fallenstein@gmail.com>**20061230143507] +[property labels kinda-sorta work+Benja Fallenstein <benja.fallenstein@gmail.com>**20061230155501] +[don't set empty text on textless nodes - hacked using mdo notation+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061230180158] +[key bindings for creating new nodes: n for new node poswards, N for new node negwards+Benja Fallenstein <benja.fallenstein@gmail.com>**20061230173043] +[key bindings for making connections. making connections between nearby nodes can lead to weird-looking view errors because our code is buggy when the same node is found on more than one path.+Benja Fallenstein <benja.fallenstein@gmail.com>**20061230175255] +[merge+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061230180414] +[use random numbers instead of time for new node ids -- the previous version would give nodes created the same second the same id :)+Benja Fallenstein <benja.fallenstein@gmail.com>**20061231123423] +[fix the key binding for comma+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061231140622] +[fix warnings+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061231141324] +[focus the canvas on click+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061231143804] +[ugly buggy load/save support+Benja Fallenstein <benja.fallenstein@gmail.com>**20061231151641] +[make looping graphs less ugly by showing the node instance with the least depth instead of the one with the greatest depth :)+Benja Fallenstein <benja.fallenstein@gmail.com>**20061231153156] +[don't make main quit with 'Prelude.undefined'. now tuukkah can make better URIs for nodes+Benja Fallenstein <benja.fallenstein@gmail.com>**20061231153907] +[make copyrighted+Benja Fallenstein <benja.fallenstein@gmail.com>**20061231155833] +[get ahead of myself+Benja Fallenstein <benja.fallenstein@gmail.com>**20061231160133] +[Fenfire, not Alph+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20061231161319] +[simplify key handler a little by monadifying it+Benja Fallenstein <benja.fallenstein@gmail.com>**20070101091038] +[tidy up handleKey some more -- still ugly, but less so+Benja Fallenstein <benja.fallenstein@gmail.com>**20070101093114] +[more cleanup; it turns out we didn't really need to keep track of whether the state was modified, at this point+Benja Fallenstein <benja.fallenstein@gmail.com>**20070101094457] +[load test graph in run-fenfire+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102014055] +[one scene has subpixel rendering, the other does not+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102014300] +[add key bindings for connection breaking+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102030013] +[don't try to be smart about rendering connection labels upside-down+Benja Fallenstein <benja.fallenstein@gmail.com>**20070101152550] +[fix warning+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102030549] +[on connect, don't add empty literal, don't move+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102033226] +[avoid duplicate triples in connect+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102033736] +[keep track of current file name+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102055457] +[try using pattern guards in connection and onConnection+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102082448] +[fix+Benja Fallenstein <benja.fallenstein@gmail.com>**20070101210809] +[merge+Benja Fallenstein <benja.fallenstein@gmail.com>**20070102101118] +[try FFI to Raptor RDF library+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102164729] +[access Raptor Statements using C2HS preprocessor+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102215146] +[use the "guess" parser and test.n3 by default+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070102215359] +[use Raptor for rdf loading in Fenfire+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103032554] +[buggy refactored version+Benja Fallenstein <benja.fallenstein@gmail.com>**20070103121221] +[Benja's update to more vobs in vobtest+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103151526] +[the fix to clipVob+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103151633] +[change transform to take a matrix transformation instead of a matrix+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103170937] +[small fixes to the text view state+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103175847] +[show old connections above new connections+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103203435] +[supress warnings about deprecations in gtk2hs+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070103224707] +[shorten connections more with depth+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070104002426] +[some comments and style in vanishingView+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070104003239] +[Makefile: touch the binary files if make needs that but ghc doesn't+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070104132634] +[Report which deprecated type Raptor gives us if any+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070104133034] +[handle the deprecated IDENTIFIER_TYPE_PREDICATE for Raptor 1.4.8+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070104153219] +[Makefile: clean *.i files. Check if Raptor parser is null+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070104133413] +[more vob refactoring+Benja Fallenstein <benja.fallenstein@gmail.com>**20070105093040] +[more vob refactoring. this is more like it+Benja Fallenstein <benja.fallenstein@gmail.com>**20070105215747] +[extract saveGraph from saveFile+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107132920] +[save uses Raptor+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107134639] +[add the interface to Raptor serializing+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107134737] +[move test.n3 to test.nt and insert space before periods to match Raptor output+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107134828] +[make setText preserve the position of the triple+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107140329] +[make Cx a monad+Benja Fallenstein <benja.fallenstein@gmail.com>**20070106231907] +[more vob refactoring+Benja Fallenstein <benja.fallenstein@gmail.com>**20070107092830] +[compile on ghc 6.6: allow-undecidable-instances for MaybeT, hide Data.Monoid.Endo+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107150126] +[cleanup Raptor.chs, fix mem leaks+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070107175019] +[force use of the hierarchical library names+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070108204002] +[properly depth-sorted vanishing view+Benja Fallenstein <benja.fallenstein@gmail.com>**20070111152552] +[make compile on ghc 6.6+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070111173814] +[get rid of ListT, use the more 'imperative' forM_ instead+Benja Fallenstein <benja.fallenstein@gmail.com>**20070111173127] +[sort nodes alphabetically+Benja Fallenstein <benja.fallenstein@gmail.com>**20070111181105] +[use the reader monad instead of the state monad in Fenfire.hs, it reduces the potential for bugs+Benja Fallenstein <benja.fallenstein@gmail.com>**20070111221405] +[handle RDF loops correctly (I hope...)+Benja Fallenstein <benja.fallenstein@gmail.com>**20070111225018] +[refactoring+Benja Fallenstein <benja.fallenstein@gmail.com>**20070111233406] +[do show connective lines even in loops+Benja Fallenstein <benja.fallenstein@gmail.com>**20070112104901] +[factor the structured cairo stuff out of Vobs.hs+Benja Fallenstein <benja.fallenstein@gmail.com>**20070115181933] +[refactor the ugly wheel code in Fenfire.hs a bit+Benja Fallenstein <benja.fallenstein@gmail.com>**20070116091204] +[kill one extra line. ha.+Benja Fallenstein <benja.fallenstein@gmail.com>**20070116091418] +[clarify some imports+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070116111355] +[try a Monoid (cx m) instance+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070116163533] +[hack in support for recognizing .turtle in addition to .ttl+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070116202011] +[wrap long lines in text widget instead of widening the window+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070116204825] +[Raptor: proper use of bracket, types and type annotations+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070116230826] +[use an even more ambitious monoid instance: instance (Monad m, Monoid o) => Monoid (m o)+Benja Fallenstein <benja.fallenstein@gmail.com>**20070118085815] +[refactor Cairo to make transformation functions nicer+Benja Fallenstein <benja.fallenstein@gmail.com>**20070120134636] +[refactor Cairo to require only an applicative functor, not a monad, as the cx functor+Benja Fallenstein <benja.fallenstein@gmail.com>**20070121092642] +[added functortest+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070121200622] +[use Control.Applicative instead of our own implementation, and start to use the preprocessor for functor syntax+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070121205115] +[use the preprocessor also for Fenfire.hs and VobTest.hs+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070121210219] +[clean up the Makefile+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070122195520] +[remove obsolete rdf parsing and serializing code+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070122200047] +[fix warnings+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070122200355] +[show *something like* Janne's daisy graphs in VobTest+Benja Fallenstein <benja.fallenstein@gmail.com>**20070125172601] +[add a keybinding for removing the literal of a node+Benja Fallenstein <benja.fallenstein@gmail.com>**20070125211944] +[when resizing the window, keep the vertical size of the text edit widget fixed+Benja Fallenstein <benja.fallenstein@gmail.com>**20070125213807] +[implement non-rotating letters and dash style in and for daisyGraph+Benja Fallenstein <benja.fallenstein@gmail.com>**20070126163243] +[show nicer daisy graphs in vobtest. the data in the repo is fake because we don't know if we can publish the real data+Benja Fallenstein <benja.fallenstein@gmail.com>**20070127113959] +[convert DaisyData.txt to iso-8859-1 for now+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070127115703] +[small refactoring in Fenfire.hs+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128124603] +[make Vobs an .fhs file+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128142748] +[refactor Cairo+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128144833] +[fix+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128145439] +[add a simple implementation of the Cairo class to Cairo.fhs+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128164747] +[more work towards making the Cairo instance in Vobs less monolithic+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128181602] +[minor cleanups+Benja Fallenstein <benja.fallenstein@gmail.com>**20070128212605] +[add profiling support to Makefile+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070129021936] +[profilable works without clean, add non-profilable target to Makefile+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070129220322] +[Do away with the buggy explicit rule for getting Raptor.o+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070202235226] +[use $(MAKE) to make recursive calls to make properly+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070203000001] +[get rid of our own transformPoint impl -- the bug is actually fixed+Benja Fallenstein <benja.fallenstein@gmail.com>**20070202201945] +[refactor the makefile a bit+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070203005833] +[include a warning comment in preprocessed fhs files+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070203010352]
+ _darcs/inventories/20070213183146-0f16d-7b9215f92f7d75ad659a4968ae9c55a9b75de4f7.gz view
@@ -0,0 +1,157 @@+Starting with tag:+[TAG kaijanaho.info fenfire-hs 2007-02-03+Automatic Date Tagger <antti-juhani@kaijanaho.fi>**20070203131731] +[add a menu bar and a toolbar+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070203133931] +[add a window icon+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204002949] +[TAG kaijanaho.info fenfire-hs 2007-02-03+Automatic Date Tagger <antti-juhani@kaijanaho.fi>**20070203215808] +[tweak code formatting+Benja Fallenstein <benja.fallenstein@gmail.com>**20070204123944] +[limit total number of nodes to show+Benja Fallenstein <benja.fallenstein@gmail.com>**20070204125846] +[place a few more nodes than we draw+Benja Fallenstein <benja.fallenstein@gmail.com>**20070204133047] +[implement key bindings with AccelGroup and ActionGroup, more actions+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204154201] +[fix graph creation, cleanup init and stateChanged+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204162436] +[implement Edit menu+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204201617] +[start a README+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204203159] +[tweak README and Makefile, add instructions+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204214912] +[actionHandler support in Vobs, move action implementations to handleAction, action tweaks+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204222808] +[confirm overwrite of same file in saveas+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204224154] +[make setText work on textless nodes+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070204230445] +[shorten main somewhat by extracting action widget creation, extract makeWindow from main+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070205002649] +[implement marking multiple nodes+Benja Fallenstein <benja.fallenstein@gmail.com>**20070205150544] +[refactor RDF.hs to make it faster. some of the code is pretty ugly, everybody please feel free to refactor it to make it nicer =-)+Benja Fallenstein <benja.fallenstein@gmail.com>**20070205162757] +[fixes+Benja Fallenstein <benja.fallenstein@gmail.com>**20070205163921] +[argh, fix order of triples in output+Benja Fallenstein <benja.fallenstein@gmail.com>**20070205164258] +[bring alphabetical sorting back, without caching -- doesn't seem too slow yet+Benja Fallenstein <benja.fallenstein@gmail.com>**20070205194703] +[add infrastructure for caching, not used yet, doesn't use weak refs yet+Benja Fallenstein <benja.fallenstein@gmail.com>**20070205200417] +[cache alphabetical sorting+Benja Fallenstein <benja.fallenstein@gmail.com>**20070206174610] +[add tool to dump darcs patch data to N-Triples+Benja Fallenstein <benja.fallenstein@gmail.com>**20070206192052] +[add some simple animation for daisy graphs -- not very good+Benja Fallenstein <benja.fallenstein@gmail.com>**20070207131301] +[refactor daisy graph code+Benja Fallenstein <benja.fallenstein@gmail.com>**20070207153307] +[use weak values in cache+Benja Fallenstein <benja.fallenstein@gmail.com>**20070208124440] +[buggy new daisy graph interpolation impl+Benja Fallenstein <benja.fallenstein@gmail.com>**20070208132416] +[twid new daisy code+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209133239] +[make ViewSettings an implicit parameter+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209160955] +[refactor Fenfire to make the state a record+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209163401] +[add support for loading multiple graphs and editing only the first of them, thus allowing us to browse the darcs data together with the project file+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209174858] +[fix the virtual darcs graph thingie+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209204420] +[makefile target to make darcs.nt which contains information about darcs commits+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209204439] +[make Cache use LRU instead of weak references, it seems that these were cleared to eagerly by the gc+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209204942] +[say on stdout when we save so that there is at least *some* feedback that the save succeeded+Benja Fallenstein <benja.fallenstein@gmail.com>**20070209205824] +[fixes: remove harp warnings, document haxml dependency, tweak makefile, add target run-project+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070210102108] +[use linked lists for the LRU functionality in the cache+Benja Fallenstein <benja.fallenstein@gmail.com>**20070210101942] +[fix logo48.png, add logo.svg and an about dialog+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070210124911] +[save button sensitivity tracks graph modification state+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070210151614] +[repo -> month -> day -> patches hierarchy to make browsing many patches easier+Benja Fallenstein <benja.fallenstein@gmail.com>**20070210132043] +[tryMove, which rotates to nearest connection if move fails+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070210161838] +[pass parent window to dialogs as an implicit parameter, confirm file closing operations with a dialog+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070210201709] +[pick start node better. I've seen less ugly code+Benja Fallenstein <benja.fallenstein@gmail.com>**20070210180652] +[explicitly hide the about dialog for gtk versions 2.10 and on+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211090143] +[add action for revert file+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211100824] +[set default action on dialogs+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211153044] +[TAG kaijanaho.info fenfire-hs+Automatic Date Tagger <antti-juhani@kaijanaho.fi>**20070210215808] +[fix interpolation when scrolling quickly by jumping scenes+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211152552] +[use URN-5 (note: uses System.Random which is not a cryptographically safe RNG)+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211161528] +[cabalize; preprocessing doesn't work, reason unknown+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211173735] +[make Cabal preprocessing work+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211182025] +[make it compile right by adding stuff to GHC-Options+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211182550] +[manage data files so that Cabal can install them+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211194519] +[do the right thing about -lraptor+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211195831] +[include README with release tarball+Benja Fallenstein <benja.fallenstein@gmail.com>**20070211200302] +[don't capitalize fenfire in cabal-generated files+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211200541] +[oops, de-capitalize fenfire in Paths_Fenfire+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211200932] +[fix cancelling in saveas dialog of confirmSave. thanks Benja for noticing!+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211203652] +[background highlight for view focus, bgColor for focus node, focusColor for keyboard focus+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211225324] +[remove the unsafe Alt-q key binding. window manager can close windows anyway+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070211232028] +[fix paned resizing+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070212004402] +[fix graph filepath from commandline to be absolute again+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070212005009] +[try a lighter background highlight+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070212115008] +[try to make the makefile compile through Cabal -- hackish+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212130002] +[twid visual appearance of the focus indicators+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212133852] +[resolve conflict+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212134356] +[twid focus indicators more+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212140542] +[oops, fix mark color+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212141724] +[integrate the haskell-src-exts code into the fenfire-hs repository+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212172743] +[rename fsFocus to fsHasFocus+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212154827] +[make setup.hs check modification times before running happy; add Preprocessor files to tarball+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212183543] +[don't fail in case that Parser.hs doesn't exist (happy hasn't been run)+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212184533] +[argh, remove *Parser.hs*, keep *Parser.ly*, don't do it the other way around+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212185658] +[remove Extra-Source-Files which is only used by the buggy sdist (we'll presumably use darcs dist instead)+Benja Fallenstein <benja.fallenstein@gmail.com>**20070212190119] +[documentation updates+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070213121132] +[force .nt suffix for now+Benja Fallenstein <benja.fallenstein@gmail.com>**20070213182113] +[update required version numbers in README+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070213182456]
+ _darcs/inventory view
@@ -0,0 +1,3 @@+Starting with tag:+[TAG fenfire-0.1+Tuukka Hastrup <Tuukka.Hastrup@iki.fi>**20070213183146]
+ _darcs/patches/20070213183146-0f16d-7b9215f92f7d75ad659a4968ae9c55a9b75de4f7.gz view

binary file changed (absent → 1340 bytes)

+ _darcs/prefs/binaries view
@@ -0,0 +1,59 @@+# Binary file regexps:+\.png$+\.PNG$+\.gz$+\.GZ$+\.pdf$+\.PDF$+\.jpg$+\.JPG$+\.jpeg$+\.JPEG$+\.gif$+\.GIF$+\.tif$+\.TIF$+\.tiff$+\.TIFF$+\.pnm$+\.PNM$+\.pbm$+\.PBM$+\.pgm$+\.PGM$+\.ppm$+\.PPM$+\.bmp$+\.BMP$+\.mng$+\.MNG$+\.tar$+\.TAR$+\.bz2$+\.BZ2$+\.z$+\.Z$+\.zip$+\.ZIP$+\.jar$+\.JAR$+\.so$+\.SO$+\.a$+\.A$+\.tgz$+\.TGZ$+\.mpg$+\.MPG$+\.mpeg$+\.MPEG$+\.iso$+\.ISO$+\.exe$+\.EXE$+\.doc$+\.DOC$+\.elc$+\.ELC$+\.pyc$+\.PYC$
+ _darcs/prefs/boring view
@@ -0,0 +1,35 @@+# Boring file regexps:+\.hi$+\.o$+\.o\.cmd$+# *.ko files aren't boring by default because they might+# be Korean translations rather than kernel modules.+# \.ko$+\.ko\.cmd$+\.mod\.c$+(^|/)\.tmp_versions($|/)+(^|/)CVS($|/)+(^|/)RCS($|/)+~$+#(^|/)\.[^/]+(^|/)_darcs($|/)+\.bak$+\.BAK$+\.orig$+(^|/)vssver\.scc$+\.swp$+(^|/)MT($|/)+(^|/)\{arch\}($|/)+(^|/).arch-ids($|/)+(^|/),+\.class$+\.prof$+(^|/)\.DS_Store$+(^|/)BitKeeper($|/)+(^|/)ChangeSet($|/)+(^|/)\.svn($|/)+\.py[co]$+\#+\.cvsignore$+(^|/)Thumbs\.db$+(^|/)autom4te\.cache($|/)
+ _darcs/prefs/defaultrepo view
@@ -0,0 +1,1 @@+/home/tuukka/darcs/fenfire-hs
+ _darcs/prefs/motd view
+ _darcs/prefs/repos view
@@ -0,0 +1,1 @@+/home/tuukka/darcs/fenfire-hs
+ _darcs/pristine/Cache.hs view
@@ -0,0 +1,112 @@+module Cache where++import Utils++import Data.Bits+import Data.HashTable (HashTable)+import qualified Data.HashTable as HashTable+import Data.Int+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (isJust, fromJust)+import Data.Unique++import Control.Monad (when)++import System.IO.Unsafe+import System.Mem.StableName+++class Hashable a where+    hash :: a -> Int32+    +instance Hashable String where+    hash s = HashTable.hashString s+    +instance Hashable Int where+    hash i = HashTable.hashInt i+    +instance Hashable Unique where+    hash u = hash (hashUnique u)+    +instance Hashable (StableName a) where+    hash n = hash (hashStableName n)+    +instance (Hashable a, Hashable b) => Hashable (a,b) where+    hash (x,y) = hash x `xor` HashTable.hashInt (fromIntegral $ hash y)+    ++type LinkedList a = IORef (LinkedNode a)++data LinkedNode a = +    LinkedNode { lnPrev :: LinkedList a, lnValue :: IORef a, +                 lnNext :: LinkedList a }+  | End { lnPrev :: LinkedList a, lnNext :: LinkedList a }+  +isEnd (LinkedNode _ _ _) = False+isEnd (End        _   _) = True+    +newList :: IO (LinkedList a)+newList = mdo let end = End p n+              p <- newIORef end; n <- newIORef end; list <- newIORef end+              return list++newNode :: a -> IO (LinkedNode a)+newNode x = do let err = error "Cache: access to not-yet-linked node"+               p <- newIORef err; val <- newIORef x; n <- newIORef err+               return (LinkedNode p val n)+               +appendNode :: LinkedNode a -> LinkedList a -> IO ()+appendNode node list = do n <- readIORef list; p <- readIORef (lnPrev n)+                          writeIORef (lnNext p) node; writeIORef (lnPrev n) node+                          writeIORef (lnPrev node) p; writeIORef (lnNext node) n+                    +removeFirst :: LinkedList a -> IO a+removeFirst list = do l <- readIORef list; node <- readIORef (lnNext l)+                      removeNode node+                      readIORef (lnValue node)++removeNode :: LinkedNode a -> IO ()+removeNode node = do when (isEnd node) $ error "Cache: remove from empty list"+                     p <- readIORef (lnPrev node); n <- readIORef (lnNext node)+                     let err = error "Cache: access to unlinked node"+                     writeIORef (lnPrev node) err; writeIORef (lnNext node) err+                     writeIORef (lnNext p) n; writeIORef (lnPrev n) p+    +access :: LinkedList a -> LinkedNode a -> IO ()+access list node = do removeNode node; appendNode node list++add :: a -> LinkedList a -> IO (LinkedNode a)+add x list = do node <- newNode x; appendNode node list; return node+++byAddress :: a -> StableName a+byAddress = unsafePerformIO . makeStableName+++type Cache key value =+    (IORef Int, Int, HashTable key (value, LinkedNode key), LinkedList key)++newCache :: (Eq key, Hashable key) => Int -> Cache key value+newCache maxsize = unsafePerformIO $ do ht <- HashTable.new (==) hash+                                        lru <- newList; size <- newIORef 0+                                        return (size, maxsize, ht, lru)++cached :: (Eq k, Hashable k) => k -> Cache k v -> v -> v+cached key (sizeRef, maxsize, cache, lru) val = unsafePerformIO $ do+    mval' <- HashTable.lookup cache key+    if isJust mval' then do+        let (val', node) = fromJust mval'+        access lru node+        --putStrLn "Cache access"+        return val'+      else do+        size <- readIORef sizeRef+        --putStrLn ("Cache add, former size " ++ show size)+        if size < maxsize then writeIORef sizeRef (size+1)+                          else do dropped <- removeFirst lru+                                  HashTable.delete cache dropped+        node <- add key lru+        HashTable.insert cache key (val, node)+        return val
+ _darcs/pristine/Cairo.fhs view
@@ -0,0 +1,193 @@+-- For (instance (Cairo cx r, Monoid m) => Monoid (cx m)):+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}+-- More, implied by the previous on GHC 6.6 but needed for earlier:+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+module Cairo where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Utils++import Control.Applicative+import Control.Monad++import Data.Monoid (Monoid(mappend, mempty))++import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)+import qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))+import qualified Graphics.Rendering.Cairo.Matrix as Matrix+import Graphics.UI.Gtk.Cairo++data Color = Color Double Double Double Double+type Size  = (Double, Double)+type Point = (Double, Double)+type Rect  = (Matrix, Size)++type Render a = C.Render a+newtype Path  = Path { renderPath :: Render () }    deriving Monoid++class (Applicative cx, Monoid r) => +      Cairo cx r | cx -> r, r -> cx where+    cxAsk    :: cx Rect+    cxLocal  :: cx Rect -> Endo (cx a)+    +    cxWrap   :: EndoM cx (Render ()) -> Endo r+    cxLocalR :: cx Rect -> Endo r++    cxRender :: cx (Render ()) -> r+    cxRender r = cxWrap (const r) mempty+    +instance Monoid (Render ()) where+    mempty = return ()+    mappend = (>>)++instance (Applicative m, Monoid o) => Monoid (m o) where+    mempty = pure mempty+    mappend = liftA2 mappend+        +instance Cairo ((->) Rect) (Rect -> Render ()) where+    cxAsk = id+    cxLocal f m r = m (f r)+    +    cxWrap f ren r = f (ren r) r+    cxLocalR f ren r = ren (f r)++newtype InContext a b = InContext { appContext :: a -> b } deriving Monoid++instance Cairo cx r => Cairo (Comp ((->) a) cx) (InContext a r) where+    cxAsk = Comp (const cxAsk)+    cxLocal (Comp f) (Comp m) = Comp $ \a -> cxLocal (f a) (m a)+    +    cxWrap f c = InContext $ \a -> cxWrap (\ren -> (fromComp $ f ren) a)+                                          (c `appContext` a)+    cxLocalR f c = InContext $ \a -> cxLocalR (fromComp f a) (c `appContext` a)++cxMatrix :: Cairo cx r => cx Matrix+cxMatrix = fmap fst cxAsk++cxSize :: Cairo cx r => cx Size+cxSize = fmap snd cxAsk+++[black, gray, lightGray, white] = [Color x x x 1 | x <- [0, 0.5, 0.9, 1]]+++fill :: Cairo cx r => cx Path -> r+fill p = cxRender $ forA2 p cxMatrix $ \p' m -> do+    renderPath p'; C.save; C.transform m; C.fill; C.restore++stroke :: Cairo cx r => cx Path -> r+stroke p = cxRender $ forA2 p cxMatrix $ \p' m -> do+    renderPath p'; C.save; C.transform m; C.stroke; C.restore++paint :: Cairo cx r => r+paint = cxRender $ pure C.paint++clip :: Cairo cx r => cx Path -> Endo r+clip p = cxWrap $ \ren -> ffor p $ \p' -> do+    C.save; renderPath p'; C.clip; ren; C.restore+    +    +withColor :: Cairo cx r => cx Color -> Endo r+withColor c = cxWrap $ \ren -> ffor c $ \(Color r g b a) -> do+    C.save; C.setSourceRGBA r g b a; ren; C.restore+    +withDash :: Cairo cx r => cx [Double] -> cx Double -> Endo r+withDash a b = cxWrap $ \ren -> #(C.save >> C.setDash !a !b >> ren >> C.restore)+    +transform :: Cairo cx r => cx (Endo Matrix) -> Endo r+transform f = cxLocalR #(!f Matrix.identity * !cxMatrix, !cxSize)++-- | Moves a renderable by x and y.+--+translate :: Cairo cx r => cx Double -> cx Double -> Endo r+translate x y = transform $ liftA2 Matrix.translate x y++-- | Moves a renderable to the specific point p.+--+translateTo :: Cairo cx r => cx Point -> Endo r+translateTo p = translate x y where+    (x,y) = funzip #(Matrix.transformPoint (Matrix.invert !cxMatrix) !p)++-- | Rotates a renderable by angle.+--+rotate :: Cairo cx r => cx Double -> Endo r+rotate angle = transform $ fmap Matrix.rotate angle++-- | Scales a renderable by sx and sy.+--+scale2 :: Cairo cx r => cx Double -> cx Double -> Endo r+scale2 sx sy = transform $ liftA2 Matrix.scale sx sy+    +-- | Scales a renderable by sc.+--+scale :: Cairo cx r => cx Double -> Endo r+scale sc = scale2 sc sc+++between :: Cairo cx r => cx Point -> cx Point -> Endo r+between p1 p2 = translate #(avg !x1 !x2) #(avg !y1 !y2)+              . rotate #(atan2 (!y2 - !y1) (!x2 - !x1)) +    where (x1,y1) = funzip p1; (x2,y2) = funzip p2+++point :: Cairo cx r => cx Double -> cx Double -> cx Point+point x y = #(Matrix.transformPoint !cxMatrix (!x,!y))++anchor :: Cairo cx r => cx Double -> cx Double -> cx Point+anchor x y = #(Matrix.transformPoint !cxMatrix (!x * !w, !y * !h))+    where (w,h) = funzip cxSize++center :: Cairo cx r => cx Point+center = anchor #0.5 #0.5++closePath :: Cairo cx r => cx Path+closePath = pure $ Path $ C.closePath++arc :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double -> cx Path+arc p a b c = #(Path $ do+    let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p+    C.save; C.transform !cxMatrix; C.arc x y !a !b !c; C.restore)++arcNegative :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double -> +               cx Path+arcNegative p a b c = #(Path $ do+    let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p+    C.save; C.transform !cxMatrix; C.arcNegative x y !a !b !c; C.restore)++circle :: Cairo cx r => cx Point -> cx Double -> cx Path+circle p r = arc p r #0 #(2*pi)++curveTo :: Cairo cx r => cx Point -> cx Point -> cx Point -> cx Path+curveTo p1 p2 p3 = forA3 p1 p2 p3 $ \(x1,y1) (x2,y2) (x3,y3) ->+                       Path $ C.curveTo x1 y1 x2 y2 x3 y3++moveTo :: Cairo cx r => cx Point -> cx Path+moveTo p = ffor p $ \(x,y) -> Path $ do C.moveTo x y++lineTo :: Cairo cx r => cx Point -> cx Path+lineTo p = ffor p $ \(x,y) -> Path $ do C.lineTo x y++line :: (Cairo cx r, Monoid (cx Path)) => cx Point -> cx Point -> cx Path+line p1 p2 = moveTo p1 & lineTo p2++extents :: (Cairo cx r, Monoid (cx Path)) => cx Path+extents = moveTo (anchor #0 #0) & lineTo (anchor #0 #1) & lineTo (anchor #1 #1)+        & lineTo (anchor #1 #0) & lineTo (anchor #0 #0)
+ _darcs/pristine/DaisyData.txt view
@@ -0,0 +1,53 @@+[+  ("A", [+    ("D", 19, 22)+  , ("NE", 3, 10)+  , ("AI", 14, 19)+  , ("B", 21, 34)+  , ("E", 33, 38)+  , ("Ä", 18, 25)+  , ("G", 24, 26)+  , ("F", 0, 1)+  , ("I", 0, 2)+  , ("H", 4, 5)+  , ("K", 10, 16)+  , ("J", 2, 5)+  , ("M", 9, 18)+  , ("L", 27, 29)+  , ("O", 9, 13)+  , ("N", 26, 28)+  , ("II", 3, 15)+  , ("P", 8, 14)+  , ("S", 1, 2)+  , ("R", 7, 18)+  , ("U", 5, 18)+  , ("T", 23, 23)+  , ("Y", 8, 10)+  , ("UI", 9, 17)+  , ("AU", 13, 23)+  ])+, ("B", [+    ("V", 4, 8)+  , ("D", 4, 25)+  , ("A", 18, 19)+  , ("E", 9, 26)+  , ("Ä", 5, 9)+  , ("G", 12, 20)+  , ("F", 7, 11)+  , ("I", 1, 15)+  , ("H", 33, 36)+  , ("K", 7, 21)+  , ("J", 19, 22)+  , ("M", 14, 37)+  , ("L", 27, 36)+  , ("O", 5, 8)+  , ("N", 19, 23)+  , ("P", 4, 5)+  , ("S", 0, 2)+  , ("R", 5, 6)+  , ("U", 14, 35)+  , ("T", 4, 23)+  , ("Ö", 22, 27)+  , ("Y", 32, 39)+  ])+]
+ _darcs/pristine/Darcs2RDF.fhs view
@@ -0,0 +1,79 @@+-- HaRP pattern translator produces following warnings:+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-incomplete-patterns #-}+module Darcs2RDF where++import Prelude hiding (elem)+import Text.XML.HaXml hiding (attr)+import Data.Maybe+import System.Environment (getArgs)++data Patch = Patch { patchHash :: String, patchName :: String,+                     patchDate :: String, patchAuthor :: String } deriving Show++patches (Document _ _ (Elem "changelog" _ c) _) = map patch (elems c) where+    patch el@(Elem "patch" _ _) = +        Patch (fromJust $ attr "hash" el) (fromJust $ elem "name" el)+              (fromJust $ attr "date" el) (fromJust $ attr "author" el)+        +triples :: String -> Patch -> String+triples repo (Patch hash name date author) =+    "<"++repo++"> <" ++ seeAlso ++ "> <"++month++">.\n" +++    "<"++month++"> <" ++ seeAlso ++ "> <"++day++">.\n" +++    "<"++month++"> <" ++ label ++ "> " ++ show (take 7 date') ++ ".\n" +++    "<"++day++"> <" ++ seeAlso ++ "> "++uri++".\n" +++    "<"++day++"> <" ++ label ++ "> " ++ show (take 10 date') ++ ".\n" +++    uri++" <"++label++"> " +++        ""++show name++".\n" +++    uri++" <foaf:author> "++authorURI ++ ".\n" +++    (if not $ null authorName+        then authorURI++" <foaf:name> "++show authorName ++ ".\n" else "") ++    +    authorURI++" <foaf:mbox> <mailto:"++authorMail ++ ">.\n" +++    uri++ " <dc:date> \""++date'++ "\"^^<xsd:dateTime>.\n"    +    where uri = "<darcs:"++hash++">"+          -- the following uses HaRP patterns+          [/ (/ authorName*, ' '*, '<', authorMail*, '>' /)+           | authorMail* /] = author+          authorURI = "<byemail:"++authorMail++">"+          [/ y@(/_,_,_,_/),m@(/_,_/),d@(/_,_/),h@(/_,_/),mi@(/_,_/),s@(/_,_/) /] = date+          date' = y++"-"++m++"-"++d++"T"++h++":"++mi++":"++s++"+0000"+          month = "ex:patches:" ++ take 7 date' ++ ":" ++ repo+          day = "ex:patches:" ++ take 10 date' ++ ":" ++ repo+          seeAlso = "http://www.w3.org/2000/01/rdf-schema#seeAlso"+          label = "http://www.w3.org/2000/01/rdf-schema#label"++elems :: [Content] -> [Element]+elems (CElem e : cs) = e : elems cs+elems (_ : cs)       = elems cs+elems []             = []++attr :: String -> Element -> Maybe String+attr name (Elem _ attrs _) = fmap getValue (lookup name attrs) where+    getValue (AttValue l) = concatMap getValue' l+    getValue' (Left s) = s+    getValue' (Right ref) = [unref ref]+    +elem :: String -> Element -> Maybe String+elem name (Elem _ _ cs) = findElem (elems cs) where+    findElem (Elem n _ c : _) | n == name = Just (text c)+    findElem (_ : cs') = findElem cs'+    findElem [] = Nothing+    +unref :: Reference -> Char+unref (RefChar c) = toEnum c+unref (RefEntity "apos") = '\''+unref (RefEntity "quot") = '"'+unref (RefEntity "lt") = '<'+unref (RefEntity "gt") = '>'+unref (RefEntity "amp") = '&'+unref _ = error "unimplemented reference thingie"+    +text :: [Content] -> String+text (CString _ s : cs) = s ++ text cs+text (CRef r : cs) = unref r : text cs+text (_ : _) = error "unimplemented content thingie"+text [] = ""+++main = do [repo] <- getArgs+          xml <- getContents+          putStr $ concatMap (triples repo) $ patches $ xmlParse "stdin" xml
+ _darcs/pristine/Fenfire.fhs view
@@ -0,0 +1,781 @@+{-# OPTIONS_GHC -fallow-overlapping-instances -fimplicit-params #-}+module Fenfire where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import qualified Cache+import Cairo hiding (rotate)+import Vobs+import Utils+import RDF++import Paths_fenfire (getDataFileName)++import qualified Raptor (filenameToTriples, triplesToFilename, Identifier(..))++import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Tree as Tree+import qualified Data.List+import Data.Set (Set)+import Data.IORef+import Data.Maybe (fromJust, isJust, isNothing, catMaybes)+import Data.Monoid(Monoid(mconcat), Dual(Dual), getDual)++import Control.Applicative+import Control.Monad (when, guard, msum)+import Control.Monad.Reader (ReaderT, runReaderT, local, ask, asks)+import Control.Monad.State (StateT, get, gets, modify, put, execStateT)+import Control.Monad.Trans (lift, liftIO)+import Control.Monad.Writer (Writer, execWriter, tell)++import Graphics.UI.Gtk hiding (Color, get, disconnect, fill)++import qualified Control.Exception+import System.Directory (canonicalizePath)+import System.Environment (getArgs, getProgName)+import System.Mem.StableName+import System.Random (randomRIO)++data ViewSettings = ViewSettings { hiddenProps :: [Node] }+data FenState = FenState { fsRotation :: Rotation, fsMark :: Mark,+                           fsFilePath :: FilePath, fsGraphModified :: Bool,+                           fsHasFocus :: Bool }++data Rotation = Rotation Graph Node Int         deriving (Eq, Show)++getRotation :: (?vs :: ViewSettings) => Graph -> Node -> Node -> Dir -> Node ->+               Maybe Rotation+getRotation graph node prop dir node' = do+    i <- Data.List.elemIndex (prop, node') (conns graph node dir)+    return (Rotation graph node +                     (i - (length (conns graph node dir) `div` 2)))+    +connsCache :: Cache.Cache (StableName Graph, (Node, Dir)) [(Node, Node)]+connsCache = Cache.newCache 10000++dc_date = URI "dc:date"++conns :: (?vs :: ViewSettings) => Graph -> Node -> Dir -> [(Node, Node)]+conns g node dir = cached where+    cached = Cache.cached (Cache.byAddress g, (node,dir)) connsCache result+    result = Data.List.sortBy cmp' list+    list = [(p,n) | (p,s) <- Map.toList $ getConns g node dir,+                    not (p `elem` hiddenProps ?vs), n <- Set.toList s]+    cmp n1 n2 | p n1 && p n2 = compare (f n1) (f n2) where+        p n = hasConn g n dc_date Pos; f n = getOne g n dc_date Pos+    cmp n1 n2 = compare (getText g n1) (getText g n2)+    cmp' (p1,n1) (p2,n2) = catOrds (cmp p1 p2) (cmp n1 n2)+    catOrds EQ o = o; catOrds o _ = o++getConn :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe (Node, Rotation)+getConn (Rotation graph node r) dir = do+    let c = conns graph node dir; i = (length c `div` 2) + r+    guard $ i >= 0 && i < length c; let (p,n) = c !! i+    rot <- getRotation graph n p (rev dir) node+    return (p,rot)+             +rotate :: (?vs :: ViewSettings) => Rotation -> Int -> Maybe Rotation+rotate (Rotation g n r) dir = let rot = Rotation g n (r+dir) in do+    guard $ any isJust [getConn rot d | d <- [Pos, Neg]]; return rot++move :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation+move rot dir = fmap snd (getConn rot dir)++getText :: Graph -> Node -> Maybe String+getText g n = fmap f $ getOne g n rdfs_label Pos where +    f (PlainLiteral s) = s; f _ = error "getText argh"+                    +setText :: Graph -> Node -> String -> Graph+setText g n t = update (n, rdfs_label, PlainLiteral t) g++nodeView :: Graph -> Node -> Vob Node+nodeView g n = rectBox $ pad 5 $ useFgColor $ multiline False 20 s+    where s = maybe (show n) id (getText g n)+    +propView :: Graph -> Node -> Vob Node+propView g n = (useFadeColor $ fill extents)+             & (pad 5 $ useFgColor $ label $ maybe (show n) id (getText g n))++++vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Color -> Color -> +                                          Color -> Color -> FenState -> Vob Node+vanishingView depth maxnodes bgColor blurBgColor focusColor blurColor+              (FenState {fsRotation=startRotation, fsMark=mark,+                         fsHasFocus=focus}) =+    runVanishing depth maxnodes view where+    -- place the center of the view and all subtrees in both directions+    view = do placeNode (if focus then Just (bgColor, focusColor) +                                  else Just (blurBgColor, blurColor))+                  startRotation+              let Rotation _ n _ = startRotation in visitNode n+              forM_ [Pos, Neg] $ \dir -> do+                  placeConns startRotation dir True+    -- place all subtrees in xdir+    placeConns rotation xdir placeFirst = withDepthIncreased 1 $ do+        when placeFirst $ placeConn rotation xdir+        forM_ [-1, 1] $ \ydir -> do+            placeConns' rotation xdir ydir+    -- place rest of the subtrees in (xdir, ydir)+    placeConns' rotation xdir ydir = withDepthIncreased 1 $+        maybeDo (rotate rotation ydir) $ \rotation' -> do+            withAngleChanged (fromIntegral ydir * mul xdir pi / 14) $ do+                placeConn rotation' xdir+                placeConns' rotation' xdir ydir+    -- place one subtree+    placeConn rotation@(Rotation graph n1 _) dir = withDepthIncreased 1 $+        maybeDo (getConn rotation dir) $ \(prop, rotation') -> do+            let Rotation _ n2 _ = rotation'+            scale' <- getScale+            withCenterMoved dir (280 * (scale'**3)) $ do+                ifUnvisited n2 $ placeNode Nothing rotation'+                let (nl,nr) = if dir==Pos then (n1,n2) else (n2,n1)+                addVob $ between (center @@ nl) (center @@ nr) $ ownSize $+                    centerVob $ scale #scale' $ propView graph prop+                addVob $ useFgColor $ stroke $+                    line (center @@ nl) (center @@ nr)+                ifUnvisited n2 $ visitNode n2 >> do+                    placeConns rotation' dir True+                    withDepthIncreased 3 $+                        placeConns rotation' (rev dir) False+    -- place one node view+    placeNode cols (Rotation graph node _) = do+        scale' <- getScale+        let f vob = case bg of Nothing -> vob+                               Just c  -> setBgColor c vob+            markColor = if node `Set.member` mark then Just (Color 1 0 0 1)+                            else Nothing+            bg = combine (fmap snd cols) markColor+            combine Nothing c = c+            combine c Nothing = c+            combine (Just c1) (Just c2) = Just $ interpolate 0.5 c1 c2+            g vob = case cols of Nothing    -> vob+                                 Just (c,_) -> frame c & vob+                where (w,h) = defaultSize vob+                      frame c = withColor #c $ fill $ +                                    moveTo (point #(0-10) #(0-10)) &+                                    lineTo (point #(w+10) #(0-10)) &+                                    lineTo (point #(w+10) #(h+10)) &+                                    lineTo (point #(0-10) #(h+10)) &+                                    lineTo (point #(0-10) #(0-10))+        placeVob $ ownSize $ scale #scale' $ keyVob node $ g $ f $ +            nodeView graph node+        +    getScale :: VV Double+    getScale = do d <- asks vvDepth; return (0.97 ** fromIntegral d)+    +    +data VVState = VVState { vvDepth :: Int, vvMaxDepth :: Int, vvMaxNodes :: Int,+                         vvX :: Double, vvY :: Double, vvAngle :: Double }+                         +type VV a = ReaderT VVState (BreadthT (StateT (Set Node) +                                          (Writer (Dual (Vob Node))))) a++runVanishing :: Int -> Int -> VV () -> Vob Node+runVanishing maxdepth maxnodes vv = comb (0,0) $ \cx -> +    let (w,h) = rcSize cx +    in getDual $ execWriter $ flip execStateT Set.empty $ execBreadthT $+           runReaderT vv $ VVState 0 maxdepth maxnodes (w/2) (h/2) 0+    +-- |Execute the passed action with the recursion depth increased by+-- the given amount of steps, if it is still smaller than the maximum+-- recursion depth.+--+withDepthIncreased :: Int -> VV () -> VV ()+withDepthIncreased n m = do+    state <- ask; let state' = state { vvDepth = vvDepth state + n }+    if vvDepth state' >= vvMaxDepth state' then return () else+        lift $ scheduleBreadthT $ flip runReaderT state' $ do+            visited <- get+            when (Set.size visited <= (4 * vvMaxNodes state') `div` 3) m+        +visitNode :: Node -> VV ()+visitNode n = modify (Set.insert n)++ifUnvisited :: Node -> VV () -> VV ()+ifUnvisited n m = do visited <- get+                     when (not $ n `Set.member` visited) m++addVob :: Vob Node -> VV ()+addVob vob = do d <- asks vvDepth; md <- asks vvMaxDepth+                mn <- asks vvMaxNodes; visited <- get+                let x = (fromIntegral (md - d) / fromIntegral (md+2))+                    vob' = if Set.size visited >= mn then invisibleVob vob+                                                     else fade x vob+                tell (Dual vob')++placeVob :: Vob Node -> VV ()+placeVob vob = do+    state <- ask+    addVob $ translate #(vvX state) #(vvY state) $ centerVob vob+        +withCenterMoved :: Dir -> Double -> VV () -> VV ()+withCenterMoved dir distance = local f where+    distance' = mul dir distance+    f s = s { vvX = vvX s + distance' * cos (vvAngle s),+              vvY = vvY s + distance' * sin (vvAngle s) }+                   +withAngleChanged :: Double -> VV () -> VV ()+withAngleChanged delta = local $ \s -> s { vvAngle = vvAngle s + delta }++++tryMove :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation+tryMove rot@(Rotation g n r) dir = maybe rot' Just (move rot dir) where+    rot' | r == nearest = Nothing+         | otherwise    = Just $ Rotation g n nearest+    nearest | r > 0     = len-1 - len `div` 2+            | otherwise = 0 - len `div` 2+    len = (length $ conns g n dir)++type URIMaker = (String, IORef Integer)++newURIMaker :: IO URIMaker+newURIMaker = do rand <- sequence [randomRIO (0,63) | _ <- [1..27::Int]]+                 let chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "+-"+                 ref <- newIORef 1+                 return ("urn:urn-5:" ++ map (chars !!) rand, ref)++newURI :: (?uriMaker :: URIMaker) => IO Node+newURI = do let (base, ref) = ?uriMaker+            i <- readIORef ref; writeIORef ref (i+1)+            return $ URI (base ++ ":" ++ show i)++newNode :: (?vs :: ViewSettings, ?uriMaker :: URIMaker) => +           Rotation -> Dir -> IO Rotation+newNode (Rotation graph node _) dir = do+    node' <- newURI+    let graph' = insert (triple dir (node, rdfs_seeAlso, node'))+               $ insert (node', rdfs_label, PlainLiteral "") graph+    return $ fromJust $ getRotation graph' node' rdfs_seeAlso (rev dir) node+    +connect :: (?vs :: ViewSettings) => Rotation -> Dir -> Mark -> Rotation+connect r _ mark | Set.null mark = r+connect (Rotation graph node _) dir mark =+    let nodes = Set.toList mark+        graph' = foldr (\n -> insert $ triple dir (node, rdfs_seeAlso, n))+                       graph nodes+    in fromJust $ getRotation graph' node rdfs_seeAlso dir (head nodes)++disconnect :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation+disconnect (Rotation graph node rot) dir = +    let+        c = conns graph node dir+        index = (length c `div` 2) + rot+        (p,n) = c !! index+        graph' = delete (triple dir (node, p, n)) graph+        index' = ((length c - 1) `div` 2) + rot+        rot' = case index' of x | x == -1                     -> rot+1+                                | x == length c - 1 && x /= 0 -> rot-1+                                | otherwise                   -> rot+    in +        if index >= 0 && index < length c +        then Just $ Rotation graph' node rot'+        else Nothing+++type Mark = Set Node++toggleMark :: Node -> Mark -> Mark+toggleMark n mark | n `Set.member` mark = Set.delete n mark+                  | otherwise           = Set.insert n mark++newGraph :: (?uriMaker :: URIMaker) => IO Rotation+newGraph = do+    home0 <- newURI++    let graph0 = listToGraph [(home0, rdfs_label, PlainLiteral "")]+        rot0 = (Rotation graph0 home0 0)++    return rot0+    +findStartRotation :: (?vs :: ViewSettings) => Graph -> Rotation+findStartRotation g = head $ catMaybes $ startNode:topic:triples where+    self = URI "ex:graph" -- ought to be what the empty URI <> is expanded to++    startNode = getRot =<< getTriple self ffv_startNode+    topic = getRot =<< getTriple self foaf_primaryTopic+    triples = map getRot $ graphToList g+    +    getTriple s p = fmap (\o -> (s,p,o)) $ getOne g s p Pos+    getRot (s,p,o) = getRotation g o p Neg s+    +    ffv_startNode = URI "http://fenfire.org/rdf-v/2003/05/ff#startNode"+    foaf_primaryTopic = URI "http://xmlns.com/foaf/0.1/primaryTopic"++loadGraph :: FilePath -> IO Graph+loadGraph fileName = do+    --file <- readFile fileName+    --graph <- fromNTriples file >>= return . reverse-}+    let convert (s,p,o) = (f s, f p, f o)+        f (Raptor.Uri s) = URI s+        f (Raptor.Literal s) = PlainLiteral s+        f (Raptor.Blank s) = URI $ "blank:" ++ s+    triples <- Raptor.filenameToTriples fileName >>= return . map convert+    return $ listToGraph triples++saveGraph :: Graph -> FilePath -> IO ()+saveGraph graph fileName = do+    --writeFile fileName $ toNTriples $ reverse graph+    let convert (s,p,o) = (f s, f p, f o)+        f (URI s) = Raptor.Uri s+        f (PlainLiteral s) = Raptor.Literal s+        triples = graphToList graph+    Raptor.triplesToFilename (map convert triples) fileName+    putStrLn $ "Saved: " ++ fileName++openFile :: (?vs :: ViewSettings) => Rotation -> FilePath -> +            IO (Rotation,FilePath)+openFile rot0 fileName0 = do+    dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen+                                   [(stockCancel, ResponseCancel),+                                    (stockOpen, ResponseAccept)]+    when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0+                                return ()+    response <- dialogRun dialog+    widgetHide dialog+    case response of+        ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog+                             graph <- loadGraph fileName+                             return (findStartRotation graph, fileName)+        _              -> return (rot0, fileName0)+        +saveFile :: Rotation -> FilePath -> Bool -> IO (FilePath,Bool)+saveFile (Rotation graph _ _) fileName0 confirmSame = do+    dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionSave+                                   [(stockCancel, ResponseCancel),+                                    (stockSave, ResponseAccept)]+    fileChooserSetDoOverwriteConfirmation dialog True+    dialogSetDefaultResponse dialog ResponseAccept+    when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0+                                return ()+    onConfirmOverwrite dialog $ do +        Just fileName <- fileChooserGetFilename dialog+        if fileName == fileName0 && not confirmSame+            then return FileChooserConfirmationAcceptFilename+            else return FileChooserConfirmationConfirm+    response <- dialogRun dialog+    widgetHide dialog+    case response of+        ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog+                             let fileName' = checkSuffix fileName+                             saveGraph graph fileName'+                             return (fileName', True)+        _              -> return (fileName0, False)+        +checkSuffix :: FilePath -> FilePath+checkSuffix s | Data.List.isSuffixOf ".nt" s = s+              | otherwise                    = s ++ ".nt"++confirmSave :: (?vs :: ViewSettings, ?pw :: Window, ?uriMaker :: URIMaker) => +               Bool -> HandlerAction FenState -> +               HandlerAction FenState+confirmSave False action = action+confirmSave True action = do+    response <- liftIO $ do+        dialog <- makeConfirmUnsavedDialog+        response' <- dialogRun dialog+        widgetHide dialog+        return response'+    case response of ResponseClose  -> action+                     ResponseAccept -> do +                         handleAction "save"+                         saved <- get >>= return . not . fsGraphModified+                         when (saved) action+                     _              -> return ()++confirmRevert :: (?vs :: ViewSettings, ?pw :: Window) => +               Bool -> HandlerAction FenState -> +               HandlerAction FenState+confirmRevert False action = action+confirmRevert True  action = do+    response <- liftIO $ do+        dialog <- makeConfirmRevertDialog+        response' <- dialogRun dialog+        widgetHide dialog+        return response'+    case response of ResponseClose  -> action+                     _              -> return ()++newState :: Rotation -> FilePath -> Bool -> FenState+newState rot fp focus = FenState rot Set.empty fp False focus++handleEvent :: (?vs :: ViewSettings, ?pw :: Window,+                ?uriMaker :: URIMaker) => Handler Event FenState+handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do+    state <- get; let rot = fsRotation state; fileName = fsFilePath state+    case key of +        x | x == "Up"    || x == "i"     -> handleAction "up"+        x | x == "Down"  || x == "comma" -> handleAction "down"+        x | x == "Left"  || x == "j"     -> handleAction "left"+        x | x == "Right" || x == "l"     -> handleAction "right"+        "O" -> handleAction "open"+        "S" -> do (fp',saved) <- liftIO $ saveFile rot fileName False+                  let modified' = fsGraphModified state && not saved+                  put $ state { fsFilePath = fp', fsGraphModified = modified' }+        _   -> unhandledEvent+handleEvent _ = unhandledEvent++handleAction :: (?vs :: ViewSettings, ?pw :: Window, +                 ?uriMaker :: URIMaker) => Handler String FenState+handleAction action = do+    FenState { fsRotation = rot@(Rotation graph node _), fsMark = mark, +               fsFilePath = filepath, fsGraphModified = modified,+               fsHasFocus=focus+             } <- get+    let m f x = maybeDo (f rot x) putRotation+        b f x = maybeDo (f rot x) $ \rot' -> do +                    putRotation rot'+                    modify $ \s -> s { fsGraphModified = modified }+        n f x = liftIO (f rot x) >>= putRotation+        o f x = putState (f rot x mark) Set.empty+    case action of+        "up"    -> b rotate (-1)    ; "down"  -> b rotate 1+        "left"  -> b tryMove Neg    ; "right" -> b tryMove Pos+        "nodel" -> n newNode Neg    ; "noder" -> n newNode Pos+        "connl" -> o connect Neg    ; "connr" -> o connect Pos+        "breakl"-> m disconnect Neg ; "breakr"-> m disconnect Pos+        "rmlit" -> putState (delLit rot) mark+        "mark"  -> putMark $ toggleMark node mark+        "new"   -> confirmSave modified $ do+            rot' <- liftIO newGraph+            put $ newState rot' "" focus+        "open"  -> confirmSave modified $ do +            (rot',fp') <- liftIO $ openFile rot filepath+            put $ newState rot' fp' focus+        "revert" | filepath /= "" -> confirmRevert modified $ do+            g' <- liftIO $ loadGraph filepath+            put $ newState (findStartRotation g') filepath focus+        "save" | filepath /= "" -> do +                     liftIO $ saveGraph graph filepath+                     modify $ \s -> s { fsGraphModified = False }+               | otherwise      -> handleAction "saveas"+        "saveas"-> do+            (fp',saved) <- liftIO $ saveFile rot filepath True+            let modified' = modified && not saved+            modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }+        "quit"  -> do confirmSave modified $ liftIO mainQuit+        "about" -> liftIO $ makeAboutDialog >>= widgetShow+        _       -> unhandledEvent+  where putRotation rot = do modify $ \state -> state { fsRotation=rot, +                                                        fsGraphModified=True }+                             setInterp True+        putMark mk      = do modify $ \state -> state { fsMark=mk }+        putState rot mk = do putMark mk; putRotation rot+        delLit (Rotation g n r) = Rotation (deleteAll n rdfs_label g) n r++makeActions actionGroup accelGroup = do+    let actionentries = +            [ ( "new"    , stockNew           )+            , ( "open"   , stockOpen          )+            , ( "save"   , stockSave          )+            , ( "saveas" , stockSaveAs        )+            , ( "revert" , stockRevertToSaved )+            , ( "quit"   , stockQuit          )+            , ( "about"  , stockAbout         )+            ]+    flip mapM actionentries $ \(name,stock) -> do +        item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label+        action <- actionNew name (siLabel $ fromJust item) Nothing (Just stock)+        actionGroupAddActionWithAccel actionGroup action Nothing+        actionSetAccelGroup action accelGroup++updateActionSensitivity actionGroup modified readable = do+    Just save <- actionGroupGetAction actionGroup "save"+    actionSetSensitive save modified+    Just revert <- actionGroupGetAction actionGroup "revert"+    actionSetSensitive revert (modified && readable)++makeBindings actionGroup bindings = do+    let bindingentries =+            [ ("noder"  , Just "_New node to right"         , +               stockMediaForward  , Just "n"              )+            , ("nodel"  , Just "N_ew node to left"          , +               stockMediaRewind   , Just "<Shift>N"       )+            , ("breakr" , Just "_Break connection to right" , +               stockGotoLast      , Just "b"              )+            , ("breakl" , Just "B_reak connection to left"  , +               stockGotoFirst     , Just "<Shift>B"       )+            , ("mark"   , Just "Toggle _mark"               ,+               stockOk            , Just "m"              )+            , ("connr"  , Just "_Connect marked to right"   ,+               stockGoForward     , Just "c"              )+            , ("connl"  , Just "C_onnect marked to left"    ,+               stockGoBack        , Just "<Shift>C"       )+            , ("rmlit"  , Just "Remove _literal text"       ,+               stockStrikethrough , Just "<Alt>BackSpace" )+            ]+    flip mapM bindingentries $ \(name,label',stock,accel) -> do +        item <- stockLookupItem stock -- XXX Gtk2Hs actionNew needs the label+        let label'' = maybe (siLabel $ fromJust item) id label'+        action <- actionNew name label'' Nothing (Just stock)+        actionGroupAddActionWithAccel actionGroup action accel+        actionSetAccelGroup action bindings++makeMenus actionGroup root = mapM_ (createMenu root) menuentries+    where+        leaf x = Tree.Node x []+        menuentries = [ Tree.Node "_File" (map leaf ["new","open","",+                                                     "save","saveas","revert",+                                                     "",+                                                     "quit"])+                      , Tree.Node "_Edit" (map leaf ["noder","nodel","",+                                                     "breakr","breakl","",+                                                     "mark","connr","connl","",+                                                     "rmlit"])+                      , Tree.Node "_Help" (map leaf ["about"])+                      ]+        createMenu :: MenuShellClass menu => menu -> Tree.Tree String -> IO ()+        createMenu parent (Tree.Node name children) = +            if children /= [] then do+                item <- menuItemNewWithMnemonic name+                menu <- menuNew+                mapM_ (createMenu menu) children+                menuItemSetSubmenu item menu+                menuShellAppend parent item+            else+                if name == "" then do+                    item <- separatorMenuItemNew+                    menuShellAppend parent item+                else do +                    Just action <- actionGroupGetAction actionGroup name+                    item <- actionCreateMenuItem action+                    menuShellAppend parent (castToMenuItem item)++makeToolbarItems actionGroup toolbar = do+    forM_ ["new", "open", "", "save"] $ \name -> +        if name == "" then do +            item <- separatorToolItemNew+            toolbarInsert toolbar item (-1)+        else do+            Just action <- actionGroupGetAction actionGroup name+            item <- actionCreateToolItem action+            toolbarInsert toolbar (castToToolItem item) (-1)+++main :: IO ()+main = do++    uriMaker <- newURIMaker++    let ?vs = ViewSettings { hiddenProps=[rdfs_label] }+        ?uriMaker = uriMaker in do++    -- initial state:++    args <- initGUI++    let view = vanishingView 20 30 +                   (Color 0.7 0.7 0.8 0.7) (Color 0.7 0.7 0.7 0.7)+                   (Color 0.93 0.93 1 1)   (Color 0.93 0.93 0.93 1)++    stateRef <- case args of +        [] -> do +            rot <- newGraph+            newIORef $ newState rot "" False+        xs -> do+            fileName:fileNames <- mapM canonicalizePath xs+            g' <- loadGraph fileName+            gs <- mapM loadGraph fileNames+            let rot = findStartRotation (foldl mergeGraphs g' gs)+            newIORef $ newState rot fileName False++    -- start:++    window <- makeWindow view stateRef+    widgetShowAll window++    mainGUI++makeWindow view stateRef = do++    -- main window:++    window <- windowNew+    let ?pw = window in mdo+    logo <- getDataFileName "data/logo48.png"+    Control.Exception.catch (windowSetIconFromFile window logo)+          (\e -> putStr ("Opening "++logo++" failed: ") >> print e)+    windowSetTitle window "Fenfire"+    windowSetDefaultSize window 800 550++    -- textview for editing:+    +    textView <- textViewNew+    textViewSetAcceptsTab textView False+    textViewSetWrapMode textView WrapWordChar++    -- this needs to be called whenever the node or its text changes:+    let stateChanged (FenState { fsRotation = Rotation g n _r, +                                 fsGraphModified=modified,+                                 fsFilePath=filepath }) = do+            buf <- textBufferNew Nothing+            textBufferSetText buf (maybe "" id $ getText g n)+            afterBufferChanged buf $ do +                start <- textBufferGetStartIter buf+                end   <- textBufferGetEndIter buf+                text  <- textBufferGetText buf start end True+                FenState { fsRotation = (Rotation g' n' r'),+                           fsFilePath = filepath' } +                    <- readIORef stateRef+                let g'' = setText g' n text -- buf corresponds to n, not to n'++                modifyIORef stateRef $ \s -> +                    s { fsRotation = Rotation g'' n' r', fsGraphModified=True }+                updateActionSensitivity actionGroup True (filepath' /= "")+                updateCanvas True++            textViewSetBuffer textView buf+            updateActionSensitivity actionGroup modified (filepath /= "")++    -- canvas for view:+    +    (canvas, updateCanvas, canvasAction) <- +        vobCanvas stateRef view handleEvent handleAction+                  stateChanged lightGray 0.5++    onFocusIn canvas $ \_event -> do +        modifyIORef stateRef $ \s -> s { fsHasFocus = True }+        windowAddAccelGroup window bindings+        updateCanvas True+        return True+    onFocusOut canvas $ \_event -> do +        modifyIORef stateRef $ \s -> s { fsHasFocus = False }+        windowRemoveAccelGroup window bindings+        updateCanvas True+        return True++    -- action widgets:++    accelGroup <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs+    windowAddAccelGroup window accelGroup+    -- bindings are active only when the canvas has the focus:+    bindings <- uiManagerNew >>= uiManagerGetAccelGroup -- XXX Gtk2Hs++    actionGroup <- actionGroupNew "main"++    makeActions actionGroup accelGroup +    makeBindings actionGroup bindings++    actions <- actionGroupListActions actionGroup+    forM_ actions $ \action -> do+        name <- actionGetName action+        onActionActivate action $ canvasAction name >> return ()++    -- user interface widgets:++    menubar <- menuBarNew+    makeMenus actionGroup menubar++    toolbar <- toolbarNew+    makeToolbarItems actionGroup toolbar++    -- layout:++    canvasFrame <- frameNew+    set canvasFrame [ containerChild := canvas+                      , frameShadowType := ShadowIn +                      ]++    textViewFrame <- frameNew+    set textViewFrame [ containerChild := textView+                      , frameShadowType := ShadowIn +                      ]++    paned <- vPanedNew+    panedAdd1 paned canvasFrame+    panedAdd2 paned textViewFrame++    vbox <- vBoxNew False 0+    boxPackStart vbox menubar PackNatural 0+    boxPackStart vbox toolbar PackNatural 0+    boxPackStart vbox paned PackGrow 0+    containerSetFocusChain vbox [toWidget paned]+    +    set paned [ panedPosition := 380, panedChildResize textViewFrame := False ]++    set window [ containerChild := vbox ]++    -- start:++    readIORef stateRef >>= stateChanged+    +    widgetGrabFocus canvas++    onDelete window $ \_event -> canvasAction "quit"++    return window+++makeAboutDialog :: (?pw :: Window) => IO AboutDialog+makeAboutDialog = do+    dialog <- aboutDialogNew+    logoFilename <- getDataFileName "data/logo.svg"+    pixbuf <- Control.Exception.catch (pixbufNewFromFile logoFilename)+                  (\e -> return $ Left (undefined, show e))+    logo <- case pixbuf of Left (_,msg)  -> do +                               putStr ("Opening "++logoFilename++" failed: ")+                               putStrLn msg+                               return Nothing+                           Right pixbuf' -> return . Just =<< +                               pixbufScaleSimple pixbuf'+                                   200 (floor (200*(1.40::Double))) +                                   InterpHyper +    set dialog [ aboutDialogName := "Fenfire" +               , aboutDialogVersion := "alpha version"+               , aboutDialogCopyright := "Licensed under GNU GPL v2 or later"+               , aboutDialogComments := +                     "An application for notetaking and RDF graph browsing."+               , aboutDialogLogo := logo+               , aboutDialogWebsite := "http://fenfire.org"+               , aboutDialogAuthors := ["Benja Fallenstein", "Tuukka Hastrup"]+               , windowTransientFor := ?pw+               ]+    onResponse dialog $ \_response -> widgetHide dialog+    return dialog++makeDialog :: (?pw :: Window) => String -> [(String, ResponseId)] -> +                                 ResponseId -> IO Dialog+makeDialog title buttons preset = do+    dialog <- dialogNew+    set dialog [ windowTitle := title+               , windowTransientFor := ?pw+               , windowModal := True+               , windowDestroyWithParent := True+               , dialogHasSeparator := False+               ]+    mapM_ (uncurry $ dialogAddButton dialog) buttons+    dialogSetDefaultResponse dialog preset+    return dialog++makeConfirmUnsavedDialog :: (?pw :: Window) => IO Dialog+makeConfirmUnsavedDialog = do +    makeDialog "Confirm unsaved changes" +        [("Discard changes", ResponseClose),+         (stockCancel, ResponseCancel),+         (stockSave, ResponseAccept)]+        ResponseAccept++makeConfirmRevertDialog :: (?pw :: Window) => IO Dialog+makeConfirmRevertDialog = do+    makeDialog "Confirm revert"+        [(stockCancel, ResponseCancel),+         (stockRevertToSaved,ResponseClose)]+        ResponseCancel
+ _darcs/pristine/FunctorSugar.hs view
@@ -0,0 +1,100 @@+{-# OPTIONS_GHC -fth #-} +module FunctorSugar where++import Control.Applicative+import Control.Monad+import Control.Monad.Writer+import Data.Maybe+import Language.Haskell.TH+import System.IO.Unsafe++functorCall :: Functor f => f a -> a+functorCall x = error "Eeene meene miste es rappelt in der kiste"++fzip :: Applicative f => f a -> f b -> f (a,b)+fzip a b = pure (\x y -> (x,y)) <*> a <*> b++fcurry :: Applicative f => (f (a,b) -> c) -> f a -> f b -> c+fcurry f x y = f (fzip x y)++functorSugar :: ExpQ -> ExpQ+functorSugar expQ = do exp <- expQ+                       (exp', calls) <- runWriterT (traverse exp)+                       appsE ([mkFMap $ length calls,+                               lamE (map (varP . fst) calls) $ return exp']+                            ++ map (return . snd) calls) ++mkFMap :: Int -> ExpQ+mkFMap 0 = [| pure |]+mkFMap 1 = [| fmap |]+mkFMap n = [| \f -> $(repeatFn (n-1) [| fcurry |]) +                        (fmap ($(repeatFn (n-1) [| uncurry |]) f)) |]+    where repeatFn :: Int -> ExpQ -> ExpQ+          repeatFn 1 e = e+          repeatFn n e = [| $e . $(repeatFn (n-1) e) |]++callExpr :: Exp+callExpr = unsafePerformIO $ runQ [| FunctorSugar.functorCall |]++type Binds = [(Name, Exp)]+type Traverse a = a -> WriterT Binds Q a++traverse :: Traverse Exp+traverse e = case e of+    VarE name -> return (VarE name)+    ConE name -> return (ConE name)+    LitE lit -> return (LitE lit)+    AppE e1 e2 | e1 == callExpr -> do name <- lift $ newName "call"+                                      tell [(name, e2)]+                                      return (VarE name)+    AppE e1 e2 -> liftM2 AppE (traverse e1) (traverse e2)+    InfixE el ei er -> do ei' <- traverse ei+                          el' <- maybe (return Nothing) +                                       (liftM Just . traverse) el+                          er' <- maybe (return Nothing) +                                       (liftM Just . traverse) er+                          return (InfixE el' ei' er')+    LamE pats e -> liftM (LamE pats) (traverse e)+    TupE exps -> liftM TupE (mapM traverse exps)+    LetE decls e -> liftM2 LetE (mapM traverseDec decls) (traverse e)+    ListE exps -> liftM ListE (mapM traverse exps)+    SigE e type' -> liftM (flip SigE type') (traverse e)+    DoE stmts -> liftM DoE (mapM traverseStmt stmts)+    CompE stmts -> liftM CompE (mapM traverseStmt stmts)+    e -> error ("expression type not implemented yet: " ++ show e)+    +traverseDec :: Traverse Dec+traverseDec decl = case decl of+    FunD name clauses -> liftM (FunD name) (mapM traverseClause clauses)+    ValD pat body decls -> liftM2 (ValD pat) (traverseBody body)+                                             (mapM traverseDec decls)+    SigD name type' -> return (SigD name type')+    -- ... possibly other things but I <benja> think not ... --+    d -> error ("declaration type not implemented: " ++ show d)++traverseClause :: Traverse Clause+traverseClause (Clause pats body decls) =+    liftM2 (Clause pats) (traverseBody body) (mapM traverseDec decls)+    +traverseBody :: Traverse Body+traverseBody (NormalB e) = liftM NormalB (traverse e)+traverseBody (GuardedB bs) = liftM GuardedB $ forM bs $ \(g,e) ->+    do e' <- traverse e; return (g,e')+    +traverseStmt :: Traverse Stmt+traverseStmt stmt = case stmt of+    BindS pat exp -> liftM (BindS pat) (traverse exp)+    LetS decs -> liftM LetS (mapM traverseDec decs)+    NoBindS exp -> liftM NoBindS (traverse exp)+    ParS stmts -> liftM ParS (mapM (mapM traverseStmt) stmts)++{-+CondE Exp Exp Exp+LetE [Dec] Exp+CaseE Exp [Match]+ArithSeqE Range+ListE [Exp]+SigE Exp Type+RecConE Name [FieldExp]+RecUpdE Exp [FieldExp]+-}
+ _darcs/pristine/FunctorTest.fhs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}++module FunctorTest where++f x = "This is not a result value: " ++ show x++foo s = f #(bar !s !s)+bar = (+)++main = putStrLn (foo [4,3,9::Integer])
+ _darcs/pristine/LICENSE view
@@ -0,0 +1,340 @@+		    GNU GENERAL PUBLIC LICENSE+		       Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++			    Preamble++  The licenses for most software are designed to take away your+freedom to share and change it.  By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users.  This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it.  (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.)  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++  To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have.  You must make sure that they, too, receive or can get the+source code.  And you must show them these terms so they know their+rights.++  We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++  Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software.  If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++  Finally, any free program is threatened constantly by software+patents.  We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary.  To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++  The precise terms and conditions for copying, distribution and+modification follow.++		    GNU GENERAL PUBLIC LICENSE+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++  0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License.  The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language.  (Hereinafter, translation is included without limitation in+the term "modification".)  Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope.  The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++  1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++  2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++    a) You must cause the modified files to carry prominent notices+    stating that you changed the files and the date of any change.++    b) You must cause any work that you distribute or publish, that in+    whole or in part contains or is derived from the Program or any+    part thereof, to be licensed as a whole at no charge to all third+    parties under the terms of this License.++    c) If the modified program normally reads commands interactively+    when run, you must cause it, when started running for such+    interactive use in the most ordinary way, to print or display an+    announcement including an appropriate copyright notice and a+    notice that there is no warranty (or else, saying that you provide+    a warranty) and that users may redistribute the program under+    these conditions, and telling the user how to view a copy of this+    License.  (Exception: if the Program itself is interactive but+    does not normally print such an announcement, your work based on+    the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole.  If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works.  But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++  3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++    a) Accompany it with the complete corresponding machine-readable+    source code, which must be distributed under the terms of Sections+    1 and 2 above on a medium customarily used for software interchange; or,++    b) Accompany it with a written offer, valid for at least three+    years, to give any third party, for a charge no more than your+    cost of physically performing source distribution, a complete+    machine-readable copy of the corresponding source code, to be+    distributed under the terms of Sections 1 and 2 above on a medium+    customarily used for software interchange; or,++    c) Accompany it with the information you received as to the offer+    to distribute corresponding source code.  (This alternative is+    allowed only for noncommercial distribution and only if you+    received the program in object code or executable form with such+    an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it.  For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable.  However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++  4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License.  Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++  5. You are not required to accept this License, since you have not+signed it.  However, nothing else grants you permission to modify or+distribute the Program or its derivative works.  These actions are+prohibited by law if you do not accept this License.  Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++  6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions.  You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++  7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all.  For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices.  Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++  8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded.  In such case, this License incorporates+the limitation as if written in the body of this License.++  9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number.  If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation.  If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++  10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission.  For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this.  Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++			    NO WARRANTY++  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++		     END OF TERMS AND CONDITIONS++	    How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software; you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation; either version 2 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program; if not, write to the Free Software+    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++    Gnomovision version 69, Copyright (C) year name of author+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary.  Here is a sample; alter the names:++  Yoyodyne, Inc., hereby disclaims all copyright interest in the program+  `Gnomovision' (which makes passes at compilers) written by James Hacker.++  <signature of Ty Coon>, 1 April 1989+  Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs.  If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library.  If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ _darcs/pristine/Makefile view
@@ -0,0 +1,60 @@++GHC?=ghc+GHCFLAGS=-fglasgow-exts -hide-package haskell98 -Wall -fno-warn-unused-imports -fno-warn-missing-signatures -fno-warn-orphans -fno-warn-deprecations++#GHCFLAGS+=-O -fexcess-precision -optc-ffast-math -optc-O3 +#crash: -optc-march=pentium4 -optc-mfpmath=sse++GHCCMD = $(GHC) $(GHCFLAGS)++C2HS?=c2hs+TRHSX?=trhsx++PREPROCESSED=$(patsubst %.fhs,%.hs,$(wildcard *.fhs)) \+             $(patsubst %.chs,%.hs,$(wildcard *.chs))+SOURCES=*.hs *.chs *.fhs $(PREPROCESSED)+TARGETS=functortest vobtest fenfire darcs2rdf++all: build++build:+	runghc Setup.hs build++profilable:+	rm -f $(TARGETS)+	$(MAKE) all+	rm -f $(TARGETS)+	$(MAKE) all "GHCFLAGS=-prof -auto-all -hisuf p_hi -osuf p_o $(GHCFLAGS)"+non-profilable:+	rm -f $(TARGETS)+	$(MAKE) all++functortest vobtest fenfire darcs2rdf: build++run-functortest: functortest+run-vobtest: vobtest+run-fenfire: ARGS=test.nt+run-fenfire: fenfire+run-darcs2rdf: darcs2rdf+run-%: %+	./dist/build/$</$< $(ARGS)++run-project: fenfire ../fenfire-project/project.nt darcs.nt+	./dist/build/fenfire/fenfire ../fenfire-project/project.nt darcs.nt $(ARGS)++darcs.nt: darcs2rdf _darcs/inventory+	darcs changes --xml | ./dist/build/darcs2rdf/darcs2rdf "http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs/" > darcs.nt++clean:+	rm -f $(PREPROCESSED) *.p_hi *.hi *.i *.chi Raptor.h Raptor_stub.* *.p_o *.o $(TARGETS)++# __attribute__ needs to be a no-op until c2hs learns to parse them in raptor.h+%.hs: %.chs+	$(C2HS) --cppopts '-D"__attribute__(A)= "' $<++%.hs: %.fhs+	echo "-- GENERATED file. Edit the ORIGINAL $< instead." >$@+	$(TRHSX) $< >>$@ || (rm $@ && exit 1)++dump-patches: darcs2rdf+	darcs changes --xml | ./darcs2rdf "http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs/" >> $(ARGS)
+ _darcs/pristine/Preprocessor/Hsx.hs view
@@ -0,0 +1,27 @@+module Preprocessor.Hsx (+	  module Preprocessor.Hsx.Syntax+	, module Preprocessor.Hsx.Build+	, module Preprocessor.Hsx.Parser+	, module Preprocessor.Hsx.Pretty+	, module Preprocessor.Hsx.Transform+	, parseFileContents+	, parseFileContentsWithMode+	, parseFile+	) where++import Preprocessor.Hsx.Build+import Preprocessor.Hsx.Syntax+import Preprocessor.Hsx.Parser+import Preprocessor.Hsx.Pretty+import Preprocessor.Hsx.Transform++parseFile :: FilePath -> IO (ParseResult HsModule)+parseFile fp = readFile fp >>= (return . parseFileContentsWithMode (ParseMode fp))++parseFileContents :: String -> ParseResult HsModule+parseFileContents = parseFileContentsWithMode defaultParseMode++parseFileContentsWithMode :: ParseMode -> String -> ParseResult HsModule+parseFileContentsWithMode p rawStr =+	let cleanStr = unlines [ s | s@(c:_) <- lines rawStr, c /= '#' ]+	 in parseModuleWithMode p cleanStr
+ _darcs/pristine/Preprocessor/Hsx/Build.hs view
@@ -0,0 +1,235 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Build+-- Original    :  Language.Haskell.Syntax+-- Copyright   :  (c) The GHC Team, 1997-2000,+--                (c) Niklas Broberg 2004+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Build (++    -- * Syntax building functions+    name,		-- :: String -> HsName+    sym,		-- :: String -> HsName+    var,		-- :: HsName -> HsExp+    op,			-- :: HsName -> HsQOp+    qvar,		-- :: Module -> HsName -> HsExp+    pvar,		-- :: HsName -> HsPat+    app,		-- :: HsExp -> HsExp -> HsExp+    infixApp,		-- :: HsExp -> HsQOp -> HsExp -> HsExp+    appFun,		-- :: HsExp -> [HsExp] -> HsExp+    pApp,		-- :: HsName -> [HsPat] -> HsPat+    tuple,		-- :: [HsExp] -> HsExp+    pTuple,		-- :: [HsPat] -> HsPat+    varTuple,		-- :: [HsName] -> HsExp+    pvarTuple,		-- :: [HsName] -> HsPat+    function,		-- :: String -> HsExp+    strE,		-- :: String -> HsExp+    charE,		-- :: Char -> HsExp+    intE,		-- :: Integer -> HsExp+    strP,		-- :: String -> HsPat+    charP,		-- :: Char -> HsPat+    intP,		-- :: Integer -> HsPat+    doE,		-- :: [HsStmt] -> HsExp+    lamE,		-- :: SrcLoc -> [HsPat] -> HsExp -> HsExp+    letE,		-- :: [HsDecl] -> HsExp -> HsExp+    caseE,		-- :: HsExp -> [HsAlt] -> HsExp+    alt,		-- :: SrcLoc -> HsPat -> HsExp -> HsAlt+    altGW,		-- :: SrcLoc -> HsPat -> [HsStmt] -> HsExp -> HsBinds -> HsAlt+    listE,		-- :: [HsExp] -> HsExp+    eList,		-- :: HsExp+    peList,		-- :: HsPat+    paren,		-- :: HsExp -> HsExp+    pParen,		-- :: HsPat -> HsPat+    qualStmt,		-- :: HsExp -> HsStmt+    genStmt,		-- :: SrcLoc -> HsPat -> HsExp -> HsStmt+    letStmt,		-- :: [HsDecl] -> HsStmt+    binds,		-- :: [HsDecl] -> HsBinds+    noBinds,		-- :: HsBinds+    wildcard,		-- :: HsPat+    genNames,		-- :: String -> Int -> [HsName]+    +    -- * More advanced building+    sfun,		-- :: SrcLoc -> HsName -> [HsName] -> HsRhs -> HsBinds -> HsDecl+    simpleFun,		-- :: SrcLoc -> HsName -> HsName -> HsExp -> HsDecl+    patBind,		-- :: SrcLoc -> HsPat -> HsExp -> HsDecl+    patBindWhere,	-- :: SrcLoc -> HsPat -> HsExp -> [HsDecl] -> HsDecl+    nameBind,		-- :: SrcLoc -> HsName -> HsExp -> HsDecl+    metaFunction,	-- :: String -> [HsExp] -> HsExp+    metaConPat		-- :: String -> [HsPat] -> HsPat+  ) where++import Preprocessor.Hsx.Syntax++-----------------------------------------------------------------------------+-- Help functions for Abstract syntax ++name :: String -> HsName+name = HsIdent++sym :: String -> HsName+sym = HsSymbol++var :: HsName -> HsExp+var = HsVar . UnQual++op :: HsName -> HsQOp+op = HsQVarOp . UnQual++qvar :: Module -> HsName -> HsExp+qvar m n = HsVar $ Qual m n++pvar :: HsName -> HsPat+pvar = HsPVar++app :: HsExp -> HsExp -> HsExp+app = HsApp++infixApp :: HsExp -> HsQOp -> HsExp -> HsExp+infixApp = HsInfixApp++appFun :: HsExp -> [HsExp] -> HsExp+appFun f [] = f+appFun f (a:as) = appFun (app f a) as++pApp :: HsName -> [HsPat] -> HsPat+pApp n ps = HsPApp (UnQual n) ps++tuple :: [HsExp] -> HsExp+tuple = HsTuple++pTuple :: [HsPat] -> HsPat+pTuple = HsPTuple++varTuple :: [HsName] -> HsExp+varTuple ns = tuple $ map var ns++pvarTuple :: [HsName] -> HsPat+pvarTuple ns = pTuple $ map pvar ns++function :: String -> HsExp+function = var . HsIdent++strE :: String -> HsExp+strE = HsLit . HsString++charE :: Char -> HsExp+charE = HsLit . HsChar++intE :: Integer -> HsExp+intE = HsLit . HsInt++strP :: String -> HsPat+strP = HsPLit . HsString++charP :: Char -> HsPat+charP = HsPLit . HsChar++intP :: Integer -> HsPat+intP = HsPLit . HsInt++doE :: [HsStmt] -> HsExp+doE = HsDo++lamE :: SrcLoc -> [HsPat] -> HsExp -> HsExp+lamE = HsLambda++letE :: [HsDecl] -> HsExp -> HsExp+letE ds e = HsLet (binds ds) e++caseE :: HsExp -> [HsAlt] -> HsExp+caseE = HsCase++alt :: SrcLoc -> HsPat -> HsExp -> HsAlt+alt s p e = HsAlt s p (HsUnGuardedAlt e) noBinds++altGW :: SrcLoc -> HsPat -> [HsStmt] -> HsExp -> HsBinds -> HsAlt+altGW s p gs e w = HsAlt s p (gAlt s gs e) w++unGAlt :: HsExp -> HsGuardedAlts+unGAlt = HsUnGuardedAlt++gAlts :: SrcLoc -> [([HsStmt],HsExp)] -> HsGuardedAlts+gAlts s as = HsGuardedAlts $ map (\(gs,e) -> HsGuardedAlt s gs e) as++gAlt :: SrcLoc -> [HsStmt] -> HsExp -> HsGuardedAlts+gAlt s gs e = gAlts s [(gs,e)]++listE :: [HsExp] -> HsExp+listE = HsList++eList :: HsExp+eList = HsList []++peList :: HsPat+peList = HsPList []++paren :: HsExp -> HsExp+paren = HsParen++pParen :: HsPat -> HsPat+pParen = HsPParen++qualStmt :: HsExp -> HsStmt+qualStmt = HsQualifier++genStmt :: SrcLoc -> HsPat -> HsExp -> HsStmt+genStmt = HsGenerator++letStmt :: [HsDecl] -> HsStmt+letStmt ds = HsLetStmt $ binds ds++binds :: [HsDecl] -> HsBinds+binds = HsBDecls++noBinds :: HsBinds+noBinds = binds []++wildcard :: HsPat+wildcard = HsPWildCard++genNames :: String -> Int -> [HsName]+genNames s k = [ HsIdent $ s ++ show i | i <- [1..k] ]++-------------------------------------------------------------------------------+-- Some more specialised help functions ++-- | A function with a single "match"+sfun :: SrcLoc -> HsName -> [HsName] -> HsRhs -> HsBinds -> HsDecl+sfun s f pvs rhs bs = HsFunBind [HsMatch s f (map pvar pvs) rhs bs]++-- | A function with a single "match", a single argument, no guards+-- and no where declarations+simpleFun :: SrcLoc -> HsName -> HsName -> HsExp -> HsDecl+simpleFun s f a e = let rhs = HsUnGuardedRhs e+		     in sfun s f [a] rhs noBinds++-- | A pattern bind where the pattern is a variable, and where+-- there are no guards and no 'where' clause.+patBind :: SrcLoc -> HsPat -> HsExp -> HsDecl+patBind s p e = let rhs = HsUnGuardedRhs e+		 in HsPatBind s p rhs noBinds++patBindWhere :: SrcLoc -> HsPat -> HsExp -> [HsDecl] -> HsDecl+patBindWhere s p e ds = let rhs = HsUnGuardedRhs e+			 in HsPatBind s p rhs (binds ds)++nameBind :: SrcLoc -> HsName -> HsExp -> HsDecl+nameBind s n e = patBind s (pvar n) e++-- meta-level functions, i.e. functions that represent functions, +-- and that take arguments representing arguments... whew!+metaFunction :: String -> [HsExp] -> HsExp+metaFunction s es = mf s (reverse es)+  where mf s []     = var $ name s+	mf s (e:es) = app (mf s es) e+++metaConPat :: String -> [HsPat] -> HsPat+metaConPat s ps = pApp (name s) ps
+ _darcs/pristine/Preprocessor/Hsx/Lexer.hs view
@@ -0,0 +1,829 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Lexer+-- Original    :  Language.Haskell.Lexer+-- Copyright   :  (c) The GHC Team, 1997-2000+--		  (c) Niklas Broberg, 2004+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Lexer for Haskell, with some extensions.+--+-----------------------------------------------------------------------------++-- 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 Preprocessor.Hsx.Lexer (Token(..), lexer) where++import Preprocessor.Hsx.ParseMonad++import Data.Char+import Data.Ratio++data Token+        = VarId String+        | QVarId (String,String)+        | IDupVarId (String)		-- duplicable implicit parameter+        | ILinVarId (String)		-- linear implicit parameter+	| ConId String+        | QConId (String,String)+	| DVarId [String]		-- to enable varid's with '-' in them+        | VarSym String+        | ConSym String+        | QVarSym (String,String)+        | QConSym (String,String)+	| IntTok Integer+	| FloatTok Rational+	| Character Char+        | StringTok String+        | Pragma String++-- Symbols++	| LeftParen+	| RightParen+	| LeftHashParen+	| RightHashParen+	| SemiColon+        | LeftCurly+        | RightCurly+        | VRightCurly			-- a virtual close brace+        | LeftSquare+        | RightSquare+	| Comma+        | Underscore+        | BackQuote++-- Reserved operators++	| Dot			-- reserved for use with 'forall x . x'+	| DotDot+	| Colon+	| DoubleColon+	| Equals+	| Backslash+	| Bar+	| LeftArrow+	| RightArrow+	| At+	| Tilde+	| DoubleArrow+	| Minus+	| Exclamation+	+-- Template Haskell+	| THExpQuote 		-- [| or [e|+	| THPatQuote		-- [p|+	| THDecQuote		-- [d|+	| THTypQuote		-- [t|         +	| THCloseQuote		-- |]+	| THIdEscape (String)	-- $x+	| THParenEscape		-- $( +	| THReifyType+	| THReifyDecl+	| THReifyFixity++-- HaRP+	| RPOpen		-- [/+	| RPClose		-- /]+	| RPSeqOpen		-- (/+	| RPSeqClose		-- /)+	| RPStar		-- *+	| RPStarG		-- *!+	| RPOpt			-- ?+	| RPOptG		-- ?!+	| RPPlus		-- ++	| RPPlusG		-- +!+	| RPEither		-- |+	| RPCAt			-- @:++-- Hsx+	| XCodeTagOpen		-- <%+	| XCodeTagClose		-- %>+	| XStdTagOpen		-- <+	| XStdTagClose		-- >+	| XCloseTagOpen		-- </+	| XEmptyTagClose	-- />+	| XPcdata String++-- Functor sugar+        | Hash                  -- #++-- Reserved Ids++	| KW_As+	| KW_Case+	| KW_Class+	| KW_Data+	| KW_Default+	| KW_Deriving+	| KW_DLet		-- implictit parameter binding+	| KW_Do+	| KW_MDo+	| KW_Else+	| KW_Forall		-- universal/existential types+        | KW_Hiding+	| 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+	| KW_With		-- implicit parameter binding+	| KW_Qualified++				-- FFI+	| KW_Foreign+	| KW_Export+	| KW_Safe+	| KW_Unsafe+	| KW_Threadsafe+	| KW_StdCall+	| KW_CCall++        | EOF+        deriving (Eq,Show)++reserved_ops :: [(String,Token)]+reserved_ops = [+ ( ".",	 Dot ),+ ( "..", DotDot ),+ ( ":",  Colon ),+ ( "::", DoubleColon ),+ ( "=",  Equals ),+ ( "\\", Backslash ),+ ( "|",  Bar ),+ ( "<-", LeftArrow ),+ ( "->", RightArrow ),+ ( "@",  At ),+ ( "~",  Tilde ),+ ( "=>", DoubleArrow ),+ ( "#",  Hash )+ ]++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 ),+ ( "data",      KW_Data ),+ ( "default",   KW_Default ),+ ( "deriving",  KW_Deriving ),+ ( "dlet",	KW_DLet ),		-- implicit parameters (hugs)+ ( "do",        KW_Do ),+ ( "else",      KW_Else ),+ ( "forall",	KW_Forall ),		-- universal/existential quantification+ ( "if",    	KW_If ),+ ( "import",    KW_Import ),+ ( "in", 	KW_In ),+ ( "infix", 	KW_Infix ),+ ( "infixl", 	KW_InfixL ),+ ( "infixr", 	KW_InfixR ),+ ( "instance",  KW_Instance ),+ ( "let", 	KW_Let ),+ ( "mdo",       KW_MDo ),+ ( "module", 	KW_Module ),+ ( "newtype",   KW_NewType ),+ ( "of", 	KW_Of ),+ ( "then", 	KW_Then ),+ ( "type", 	KW_Type ),+ ( "where", 	KW_Where ),+ ( "with",	KW_With ),		-- implicit parameters++-- Template Haskell+ ( "reifyDecl", THReifyDecl ),+ ( "reifyType", THReifyType ),+ ( "reifyFixity", THReifyFixity ),++-- FFI+ ( "foreign", 	KW_Foreign )+ ]+++special_varids :: [(String,Token)]+special_varids = [+ ( "as", 	KW_As ),+ ( "qualified", KW_Qualified ),+ ( "hiding", 	KW_Hiding ),++-- FFI+ ( "export",	KW_Export),+ ( "safe",	KW_Safe),+ ( "unsafe",	KW_Unsafe),+ ( "threadsafe", KW_Threadsafe),+ ( "stdcall",	KW_StdCall),+ ( "ccall",	KW_CCall)+ ]++isIdent, isHSymbol :: Char -> Bool+isIdent   c = isAlpha c || isDigit c || c == '\'' || c == '_'+isHSymbol 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, ws) <- lexWhiteSpace bol+	-- take care of whitespace in PCDATA+	ec <- getExtContext+	case ec of+	 -- if there was no linebreak, and we are lexing PCDATA,+	 -- then we want to care about the whitespace+	 Just ChildCtxt | not bol && ws -> return $ XPcdata " "+	 _ -> do startToken+		 if bol then lexBOL else lexToken ++lexWhiteSpace :: Bool -> Lex a (Bool, Bool)+lexWhiteSpace bol = do+	s <- getInput+	case s of+	    '{':'-':c:_ | c /= '#' -> do+		discard 2+		bol <- lexNestedComment bol+		(bol, _) <- lexWhiteSpace bol+		return (bol, True)+	    '-':'-':s | all (== '-') (takeWhile isHSymbol s) -> do+		lexWhile (== '-')+		lexWhile (/= '\n')+		lexNewline+		lexWhiteSpace True+		return (True, True)+	    '\n':_ -> do+		lexNewline+		lexWhiteSpace True+		return (True, True)+	    '\t':_ -> do+		lexTab+		(bol, _) <- lexWhiteSpace bol+		return (bol, True)		+	    c:_ | isSpace c -> do+		discard 1+		(bol, _) <- lexWhiteSpace bol+		return (bol, True)+	    _ -> return (bol, False)+	    +lexPragma :: String -> Lex a String+lexPragma str = do+	s <- getInput+	case s of+	    '#':'-':'}':_ -> do+	        discard 3 >> return str+	    '\t':_ -> lexTab >> lexPragma (str ++ "\t")+	    '\n':_ -> lexNewline >> lexPragma (str ++ "\n")+	    c:_ -> discard 1 >> lexPragma (str ++ [c])+	    []  -> fail "Unterminated pragma"++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+	ec <- getExtContext+	case ec of+	 Just HarpCtxt 	   -> lexHarpToken+	 Just TagCtxt	   -> lexTagCtxt+	 Just CloseTagCtxt -> lexCloseTagCtxt+	 Just ChildCtxt    -> lexChildCtxt+	 Just CodeTagCtxt  -> lexCodeTagCtxt+	 _ 		   -> lexStdToken+++lexChildCtxt :: Lex a Token+lexChildCtxt = do+    s <- getInput+    case s of+    	'<':'%':_ -> do discard 2+    			pushExtContextL CodeTagCtxt+    			return XCodeTagOpen+    	'<':'/':_ -> do discard 2+    			popExtContextL "lexChildCtxt"+    			pushExtContextL CloseTagCtxt+    			return XCloseTagOpen+    	'<':_	  -> do discard 1+    			pushExtContextL TagCtxt+    			return XStdTagOpen+    	'[':'/':_ -> do discard 2+    			pushExtContextL HarpCtxt+    			return RPOpen+    	_	  -> lexPCDATA+++lexPCDATA :: Lex a Token+lexPCDATA = do+    s <- getInput+    case s of+    	[] -> return EOF+    	_  -> case s of+		'\n':_ -> do+			x <- lexNewline >> lexPCDATA+			case x of+			 XPcdata p -> return $ XPcdata $ '\n':p+			 EOF -> return EOF+		'<':_ -> return $ XPcdata ""+		'[':'/':_ -> return $ XPcdata ""+		'[':s' -> do discard 1+			     pcd <- lexPCDATA+			     case pcd of+			      XPcdata pcd' -> return $ XPcdata $ '[':pcd'+			      EOF -> return EOF+		_ -> do let pcd = takeWhile (\c -> not $ elem c "<[\n") s+        	     	    l = length pcd+    	         	discard l+			x <- lexPCDATA+			case x of+			 XPcdata pcd' -> return $ XPcdata $ pcd ++ pcd'+			 EOF -> return EOF+++lexCodeTagCtxt :: Lex a Token+lexCodeTagCtxt = do+    s <- getInput+    case s of+        '%':'>':_ -> do discard 2+        		popExtContextL "lexCodeTagContext"+        		return XCodeTagClose+        _	  -> lexStdToken++lexCloseTagCtxt :: Lex a Token+lexCloseTagCtxt = do+    s <- getInput+    case s of+    	'>':_ 	  -> do discard 1+    			popExtContextL "lexCloseTagCtxt"+    			return XStdTagClose+    	_	  -> lexStdToken++lexTagCtxt :: Lex a Token+lexTagCtxt = do+    s <- getInput+    case s of+    	'/':'>':_ -> do discard 2+    			popExtContextL "lexTagCtxt: Empty tag"+    			return XEmptyTagClose+    	'>':_	  -> do discard 1+    			popExtContextL "lexTagCtxt: Standard tag"+    			pushExtContextL ChildCtxt+    			return XStdTagClose+    	_	  -> lexStdToken++lexHarpToken :: Lex a Token+lexHarpToken = do+    s <- getInput+    case s of+    	'[':'/':_ -> do discard 2+    			pushExtContextL HarpCtxt+    			return RPOpen+    	'/':']':_ -> do discard 2+    			popExtContextL "lexHarpToken"+    			return RPClose+    	'(':'/':_ -> do discard 2+    			return RPSeqOpen+    	'/':')':_ -> do discard 2+    			return RPSeqClose+    	'*':'!':_ -> do discard 2+    			return RPStarG+    	'*':_ 	  -> do discard 1+    			return RPStar+    	'+':'!':_ -> do discard 2+    			return RPPlusG+    	'+':_	  -> do discard 1+    			return RPPlus+    	'|':_	  -> do discard 1+    			return RPEither+    	'?':'!':_ -> do discard 2+    			return RPOptG+    	'?':_	  -> do discard 1+    			return RPOpt+    	'@':':':_ -> do discard 2+    			return RPCAt+    	_	  -> lexStdToken++lexStdToken :: Lex a Token+lexStdToken = do+    s <- getInput+    case s of+        [] -> return EOF++        '{':'-':'#':_ -> do+	        discard 3+	        pragma <- lexPragma "" +	        return (Pragma pragma)++	'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)+	+	-- implicit parameters+	'?':c:_ | isLower c -> do+			discard 1+			id <- lexWhile isIdent+			return $ IDupVarId id++	'%':c:_ | isLower c -> do+			discard 1+			id <- lexWhile isIdent+			return $ ILinVarId id+	-- end implicit parameters++	-- harp+	'[':'/':_ -> do+			discard 2+			pushExtContextL HarpCtxt+			return RPOpen			+	+	-- template haskell+	'[':'|':_ -> do+			discard 2+			return $ THExpQuote+	+	'[':c:'|':_ | c == 'e' -> do+			discard 3+			return $ THExpQuote+		    | c == 'p' -> do+		    	discard 3+		    	return THPatQuote+		    | c == 'd' -> do+		    	discard 3+		    	return THDecQuote+		    | c == 't' -> do+		    	discard 3+		    	return THTypQuote+		    	+	'|':']':_ -> do discard 2+		        return THCloseQuote+		      +	'$':c:_ | isLower c -> do+			discard 1+			id <- lexWhile isIdent+			return $ THIdEscape id+		| c == '(' -> do+			discard 2+			return THParenEscape+	-- end template haskell+	+	-- hsx+	'<':'%':_ -> do discard 2+			pushExtContextL CodeTagCtxt+			return XCodeTagOpen+	'<':c:_ | isAlpha c -> do discard 1+				  pushExtContextL TagCtxt+				  return XStdTagOpen+	-- end hsx+	+	'(':'#':_ -> do discard 2 >> return LeftHashParen+	+	'#':')':_ -> do discard 2 >> return RightHashParen+	+	c:_ | isDigit c -> lexDecimalOrFloat++	    | isUpper c -> lexConIdOrQual ""++	    | isLower c || c == '_' -> do+		idents <- lexIdents+		case idents of+		 [ident] -> return $ case lookup ident (reserved_ids ++ special_varids) of+				      Just keyword -> keyword+				      Nothing -> VarId ident+		 _ -> return $ DVarId idents++	    | isHSymbol c -> do+		sym <- lexWhile isHSymbol+		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 "lexStdToken"+			    return RightCurly++		    '\'' -> do+			    c2 <- lexChar+			    matchChar '\'' "Improperly terminated character constant"+			    return (Character c2)++		    '"' ->  lexString++		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")++      where lexIdents :: Lex a [String]+	    lexIdents = do+		ident <- lexWhile isIdent+		s <- getInput+		case s of+		 '-':c:_ | isIdent c -> do +				discard 1+				idents <- lexIdents+				return $ ident : idents+		 _ -> return [ident]++++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'++	     | isHSymbol c -> do	-- qualified symbol?+		discard 1+		sym <- lexWhile isHSymbol+		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 <= 0x01FFFF = 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)
+ _darcs/pristine/Preprocessor/Hsx/ParseMonad.hs view
@@ -0,0 +1,292 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.ParseMonad+-- Original    :  Language.Haskell.ParseMonad+-- Copyright   :  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  portable+--+-- Monads for the Haskell parser and lexer.+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.ParseMonad(+		-- * Parsing+		P, ParseResult(..), atSrcLoc, LexContext(..),+		ParseMode(..), defaultParseMode,+		runParserWithMode, runParser,+		getSrcLoc, pushCurrentContext, popContext,+		-- * Lexing+		Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,+		alternative, checkBOL, setBOL, startToken, getOffside,+		pushContextL, popContextL,+		-- * Harp/Hsx+		ExtContext(..),+		pushExtContextL, popExtContextL, getExtContext,+		getModuleName+	) where++import Preprocessor.Hsx.Syntax(SrcLoc(..))++import Data.List ( intersperse )++-- | The result of a parse.+data ParseResult a+	= ParseOk a		-- ^ The parse succeeded, yielding a value.+	| ParseFailed SrcLoc String+				-- ^ The parse failed at the specified+				-- source location, with an error message.+	deriving Show++-- internal version+data ParseStatus a = Ok ParseState a | Failed SrcLoc String+	deriving Show++data LexContext = NoLayout | Layout Int+	deriving (Eq,Ord,Show)+	+data ExtContext = CodeCtxt | HarpCtxt | TagCtxt | ChildCtxt +		| CloseTagCtxt | CodeTagCtxt+	deriving (Eq,Ord,Show)++type ParseState = ([LexContext],[ExtContext])++indentOfParseState :: ParseState -> Int+indentOfParseState (Layout n:_,_) = n+indentOfParseState _            = 0++-- | Static parameters governing a parse.+-- More to come later, e.g. literate mode, language extensions.++data ParseMode = ParseMode {+		-- | original name of the file being parsed+		parseFilename :: String+		}++-- | Default parameters for a parse,+-- currently just a marker for an unknown filename.++defaultParseMode :: ParseMode+defaultParseMode = ParseMode {+		parseFilename = "<unknown>.hs"+		}++-- | Monad for parsing++newtype P a = P { runP ::+		        String		-- input string+		     -> Int		-- current column+		     -> Int		-- current line+		     -> SrcLoc		-- location of last token read+		     -> ParseState	-- layout info.+		     -> ParseMode	-- parse parameters+		     -> ParseStatus a+		}++runParserWithMode :: ParseMode -> P a -> String -> ParseResult a+runParserWithMode mode (P m) s = case m s 0 1 start ([],[]) mode of+	Ok _ a -> ParseOk a+	Failed loc msg -> ParseFailed loc msg+    where start = SrcLoc {+		srcFilename = parseFilename mode,+		srcLine = 1,+		srcColumn = 1+	}++runParser :: P a -> String -> ParseResult a+runParser = runParserWithMode defaultParseMode++instance Monad P where+	return a = P $ \_i _x _y _l s _m -> Ok s a+	P m >>= k = P $ \i x y l s mode ->+		case m i x y l s mode of+		    Failed loc msg -> Failed loc msg+		    Ok s' a -> runP (k a) i x y l s' mode+	fail s = P $ \_r _col _line loc _stk _m -> Failed loc s++atSrcLoc :: P a -> SrcLoc -> P a+P m `atSrcLoc` loc = P $ \i x y _l -> m i x y loc++getSrcLoc :: P SrcLoc+getSrcLoc = P $ \_i _x _y l s _m -> Ok s l++getModuleName :: P String+getModuleName = P $ \_i _x _y _l s m -> +    let fn = parseFilename m+    	mn = concat $ intersperse "." $ splitPath fn+  	+	splitPath :: String -> [String]+	splitPath ""   = []+   	splitPath str  = let (l,str') = break ('\\'==) str+			  in case str' of +			      []      -> [removeSuffix l]+			      (_:str'') -> l : splitPath str''+	+	removeSuffix l = reverse $ tail $ dropWhile ('.'/=) $ reverse l++     in Ok s mn++-- Enter a new layout context.  If we are already in a layout context,+-- ensure that the new indent is greater than the indent of that context.+-- (So if the source loc is not to the right of the current indent, an+-- empty list {} will be inserted.)++pushCurrentContext :: P ()+pushCurrentContext = do+	loc <- getSrcLoc+	indent <- currentIndent+	pushContext (Layout (srcColumn loc))++currentIndent :: P Int+currentIndent = P $ \_r _x _y loc stk _mode -> Ok stk (indentOfParseState stk)++pushContext :: LexContext -> P ()+pushContext ctxt =+--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $+	P $ \_i _x _y _l (s, e) _m -> Ok (ctxt:s, e) ()++popContext :: P ()+popContext = P $ \_i _x _y _l stk _m ->+      case stk of+   	(_:s, e) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $+            Ok (s, e) ()+        ([],_)    -> error "Internal error: empty context in popContext"+++-- HaRP/Hsx+pushExtContext :: ExtContext -> P ()+pushExtContext ctxt = P $ \_i _x _y _l (s, e) _m -> Ok (s, ctxt:e) ()++popExtContext :: P ()+popExtContext = P $ \_i _x _y _l (s, e) _m ->+	case e of+	 (_:e') -> +	   Ok (s, e') ()+	 [] -> error "Internal error: empty context in popExtContext"+++-- Monad for lexical analysis:+-- a continuation-passing version of the parsing monad++newtype Lex r a = Lex { runL :: (a -> P r) -> P r }++instance Monad (Lex r) where+	return a = Lex $ \k -> k a+	Lex v >>= f = Lex $ \k -> v (\a -> runL (f a) k)+	Lex v >> Lex w = Lex $ \k -> v (\_ -> w k)+	fail s = Lex $ \_ -> fail s++-- Operations on this monad++getInput :: Lex r String+getInput = Lex $ \cont -> P $ \r -> runP (cont r) r++-- | Discard some input characters (these must not include tabs or newlines).++discard :: Int -> Lex r ()+discard n = Lex $ \cont -> P $ \r x -> runP (cont ()) (drop n r) (x+n)++-- | Discard the next character, which must be a newline.++lexNewline :: Lex a ()+lexNewline = Lex $ \cont -> P $ \(_:r) _x y -> runP (cont ()) r 1 (y+1)++-- | Discard the next character, which must be a tab.++lexTab :: Lex a ()+lexTab = Lex $ \cont -> P $ \(_:r) x -> runP (cont ()) r (nextTab x)++nextTab :: Int -> Int+nextTab x = x + (tAB_LENGTH - (x-1) `mod` tAB_LENGTH)++tAB_LENGTH :: Int+tAB_LENGTH = 8 :: Int++-- Consume and return the largest string of characters satisfying p++lexWhile :: (Char -> Bool) -> Lex a String+lexWhile p = Lex $ \cont -> P $ \r x ->+	let (cs,rest) = span p r in+	runP (cont cs) rest (x + length cs)++-- An alternative scan, to which we can return if subsequent scanning+-- is unsuccessful.++alternative :: Lex a v -> Lex a (Lex a v)+alternative (Lex v) = Lex $ \cont -> P $ \r x y ->+	runP (cont (Lex $ \cont' -> P $ \_r _x _y ->+		runP (v cont') r x y)) r x y++-- The source location is the coordinates of the previous token,+-- or, while scanning a token, the start of the current token.++-- col is the current column in the source file.+-- We also need to remember between scanning tokens whether we are+-- somewhere at the beginning of the line before the first token.+-- This could be done with an extra Bool argument to the P monad,+-- but as a hack we use a col value of 0 to indicate this situation.++-- Setting col to 0 is used in two places: just after emitting a virtual+-- close brace due to layout, so that next time through we check whether+-- we also need to emit a semi-colon, and at the beginning of the file,+-- by runParser, to kick off the lexer.+-- Thus when col is zero, the true column can be taken from the loc.++checkBOL :: Lex a Bool+checkBOL = Lex $ \cont -> P $ \r x y loc ->+		if x == 0 then runP (cont True) r (srcColumn loc) y loc+			else runP (cont False) r x y loc++setBOL :: Lex a ()+setBOL = Lex $ \cont -> P $ \r _ -> runP (cont ()) r 0++-- Set the loc to the current position++startToken :: Lex a ()+startToken = Lex $ \cont -> P $ \s x y _ stk mode ->+	let loc = SrcLoc {+		srcFilename = parseFilename mode,+		srcLine = y,+		srcColumn = x+	} in+	runP (cont ()) s x y loc stk mode++-- Current status with respect to the offside (layout) rule:+-- LT: we are to the left of the current indent (if any)+-- EQ: we are at the current indent (if any)+-- GT: we are to the right of the current indent, or not subject to layout++getOffside :: Lex a Ordering+getOffside = Lex $ \cont -> P $ \r x y loc stk ->+		runP (cont (compare x (indentOfParseState stk))) r x y loc stk++pushContextL :: LexContext -> Lex a ()+pushContextL ctxt = Lex $ \cont -> P $ \r x y loc (stk, e) ->+		runP (cont ()) r x y loc (ctxt:stk, e)++popContextL :: String -> Lex a ()+popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of+		(_:ctxt, e) -> runP (cont ()) r x y loc (ctxt, e)+		([], _)     -> error ("Internal error: empty context in " ++ fn)++-- Harp/Hsx++getExtContext :: Lex a (Maybe ExtContext)+getExtContext = Lex $ \cont -> P $ \r x y loc stk@(_, e) ->+		let me = case e of+			  [] -> Nothing+			  (c:_) -> Just c+		in runP (cont me) r x y loc stk++pushExtContextL :: ExtContext -> Lex a ()+pushExtContextL ec = Lex $ \cont -> P $ \r x y loc (s, e) ->+		runP (cont ()) r x y loc (s, ec:e)++popExtContextL :: String -> Lex a ()+popExtContextL fn = Lex $ \cont -> P $ \r x y loc stk@(s,e) -> case e of+			(_:ec) -> runP (cont ()) r x y loc (s,ec)+			[]       -> error ("Internal error: empty tag context in " ++ fn)
+ _darcs/pristine/Preprocessor/Hsx/ParseUtils.hs view
@@ -0,0 +1,548 @@+-- #hide+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.ParseUtils+-- Original    :  Language.Haskell.ParseUtils+-- Copyright   :  (c) Niklas Broberg 2004,+-- 		  (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Utilities for the Haskell-exts parser.+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.ParseUtils (+	  splitTyConApp		-- HsType -> P (HsName,[HsType])+	, mkRecConstrOrUpdate	-- HsExp -> [HsFieldUpdate] -> P HsExp+	, checkPrec		-- Integer -> P Int+	, checkContext		-- HsType -> P HsContext+	, checkAssertion	-- HsType -> P HsAsst+	, checkDataHeader	-- HsType -> P (HsContext,HsName,[HsName])+	, checkClassHeader	-- HsType -> P (HsContext,HsName,[HsName])+	, checkInstHeader	-- HsType -> P (HsContext,HsQName,[HsType])+	, checkPattern		-- HsExp -> P HsPat+	, checkExpr		-- HsExp -> P HsExp+	, checkValDef		-- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl+	, checkClassBody	-- [HsDecl] -> P [HsDecl]+	, checkUnQual		-- HsQName -> P HsName+	, checkRevDecls		-- [HsDecl] -> P [HsDecl]+	, getGConName		-- HsExp -> P HsQName+	, mkHsTyForall		-- Maybe [HsName] -> HsContext -> HsType -> HsType +	-- HaRP+	, checkRPattern		-- HsExp -> P HsRPat+	-- Hsx+	, checkEqNames		-- HsXName -> HsXName -> P HsXName+	, mkPageModule		-- HsExp -> P HsModule+	, mkPage		-- HsModule -> SrcLoc -> HsExp -> P HsModule+	, mkDVar		-- [String] -> String+	, mkDVarExpr		-- [String] -> HsExp+	) where++import Preprocessor.Hsx.Syntax+import Preprocessor.Hsx.ParseMonad+import Preprocessor.Hsx.Pretty+import Preprocessor.Hsx.Build++import Data.List (intersperse)++splitTyConApp :: HsType -> P (HsName,[HsType])+splitTyConApp t0 = split t0 []+ where+	split :: HsType -> [HsType] -> P (HsName,[HsType])+	split (HsTyApp t u) ts = split t (u:ts)+	split (HsTyCon (UnQual t)) ts = return (t,ts)+        split (HsTyInfix a op b) ts = split (HsTyCon op) (a:b:ts)+	split _ _ = fail "Illegal data/newtype declaration"++-----------------------------------------------------------------------------+-- Various Syntactic Checks++checkContext :: HsType -> P HsContext+checkContext (HsTyTuple Boxed ts) =+	mapM checkAssertion ts+checkContext t = do+	c <- checkAssertion t+	return [c]++-- Changed for multi-parameter type classes.+-- Further changed for implicit parameters.++checkAssertion :: HsType -> P HsAsst+checkAssertion (HsTyPred p@(HsIParam n t)) = return p+checkAssertion t = checkAssertion' [] t+	where	checkAssertion' ts (HsTyCon c) = return $ HsClassA c ts+		checkAssertion' ts (HsTyApp a t) = checkAssertion' (t:ts) a+                checkAssertion' ts (HsTyInfix a op b) = checkAssertion' (a:b:ts) (HsTyCon op)+		checkAssertion' _ _ = fail "Illegal class assertion"+++checkDataHeader :: HsType -> P (HsContext,HsName,[HsName])+checkDataHeader (HsTyForall Nothing cs t) = do+	(c,ts) <- checkSimple "data/newtype" t []+	return (cs,c,ts)+checkDataHeader t = do+	(c,ts) <- checkSimple "data/newtype" t []+	return ([],c,ts)++checkClassHeader :: HsType -> P (HsContext,HsName,[HsName])+checkClassHeader (HsTyForall Nothing cs t) = do+	(c,ts) <- checkSimple "class" t []+	return (cs,c,ts)+checkClassHeader t = do+	(c,ts) <- checkSimple "class" t []+	return ([],c,ts)++checkSimple :: String -> HsType -> [HsName] -> P (HsName,[HsName])+checkSimple kw (HsTyApp l (HsTyVar a)) xs = checkSimple kw l (a:xs)+checkSimple _  (HsTyInfix (HsTyVar a) (UnQual t) (HsTyVar b)) xs = return (t,a:b:xs)+checkSimple _kw (HsTyCon (UnQual t))   xs = return (t,xs)+checkSimple kw _ _ = fail ("Illegal " ++ kw ++ " declaration")++checkInstHeader :: HsType -> P (HsContext,HsQName,[HsType])+checkInstHeader (HsTyForall Nothing cs t) = do+	(c,ts) <- checkInsts t []+	return (cs,c,ts)+checkInstHeader t = do+	(c,ts) <- checkInsts t []+	return ([],c,ts)+	++checkInsts :: HsType -> [HsType] -> P ((HsQName,[HsType]))+checkInsts (HsTyApp l t) ts = checkInsts l (t:ts)+checkInsts (HsTyCon c)   ts = return (c,ts)+checkInsts _ _ = fail "Illegal instance declaration"++{-+checkInst :: HsType -> P ()+checkInst (HsTyApp l _) = checkInst l+checkInst (HsTyVar _)   = fail "Illegal instance declaration"+checkInst _             = return ()+-}++-----------------------------------------------------------------------------+-- Checking Patterns.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: HsExp -> P HsPat+checkPattern e = checkPat e []++checkPat :: HsExp -> [HsPat] -> P HsPat+checkPat (HsCon c) args = return (HsPApp c args)+checkPat (HsApp f x) args = do+	x <- checkPat x []+	checkPat f (x:args)+checkPat e [] = case e of+	HsVar (UnQual x)   -> return (HsPVar x)+	HsLit l            -> return (HsPLit l)+	HsInfixApp l op r  -> do+			      l <- checkPat l []+			      r <- checkPat r []+			      case op of+				 HsQConOp c -> return (HsPInfixApp l c r)+				 _ -> patFail ""+	HsTuple es         -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPTuple ps)+	HsList es	   -> do+			      ps <- mapM (\e -> checkPat e []) es+			      return (HsPList ps)+	HsParen e	   -> do+			      p <- checkPat e []+			      return (HsPParen p)+	HsAsPat n e	   -> do+			      p <- checkPat e []+			      return (HsPAsPat n p)+	HsWildCard	   -> return HsPWildCard+	HsIrrPat e	   -> do+			      p <- checkPat e []+			      return (HsPIrrPat p)+	HsRecConstr c fs   -> do+			      fs <- mapM checkPatField fs+			      return (HsPRec c fs)+	HsNegApp (HsLit l) -> return (HsPNeg (HsPLit l))+	HsRPats s es	   -> do+			      rps <- mapM checkRPattern es+			      return (HsPRPat s rps)+	HsExpTypeSig s e t -> do+			      p <- checkPat e []+			      return (HsPatTypeSig s p t)+	+	-- Hsx+	HsXTag s n attrs mattr cs -> do+			      pattrs <- mapM checkPAttr attrs+			      pcs    <- mapM (\c -> checkPat c []) cs+			      mpattr <- maybe (return Nothing) +			      		  (\e -> do p <- checkPat e []+			      		  	    return $ Just p) +			      		  mattr+			      let cp = mkChildrenPat pcs+			      return $ HsPXTag s n pattrs mpattr cp+	HsXETag s n attrs mattr -> do+			      pattrs <- mapM checkPAttr attrs+			      mpattr <- maybe (return Nothing) +			      		  (\e -> do p <- checkPat e []+			      		  	    return $ Just p) +			      		  mattr+			      return $ HsPXETag s n pattrs mpattr+	HsXPcdata pcdata   -> return $ HsPXPcdata pcdata+	HsXExpTag e	   -> do+			      p <- checkPat e []+			      return $ HsPXPatTag p+	e -> patFail $ show e++checkPat e _ = patFail $ show e++checkPatField :: HsFieldUpdate -> P HsPatField+checkPatField (HsFieldUpdate n e) = do+	p <- checkPat e []+	return (HsPFieldPat n p)++checkPAttr :: HsXAttr -> P HsPXAttr+checkPAttr (HsXAttr n v) = do p <- checkPat v []+			      return $ HsPXAttr n p++patFail :: String -> P a+patFail s = fail $ "Parse error in pattern: " ++ s++checkRPattern :: HsExp -> P HsRPat+checkRPattern e = case e of+	HsSeqRP es	  -> do +			     rps <- mapM checkRPattern es+			     return $ HsRPSeq rps+	HsStarRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPStar rp+	HsPlusRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPPlus rp +	HsOptRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPOpt rp +	HsStarGRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPStarG rp+	HsPlusGRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPPlusG rp +	HsOptGRP e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPOptG rp +	HsEitherRP e1 e2  -> do+			     rp1 <- checkRPattern e1+			     rp2 <- checkRPattern e2+			     return $ HsRPEither rp1 rp2+	HsCAsRP n e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPCAs n rp+	HsAsPat	n e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPAs n rp+	HsParen e	  -> do+			     rp <- checkRPattern e+			     return $ HsRPParen rp+	_	          -> do+			     p <- checkPattern e+			     return $ HsRPPat p+++mkChildrenPat :: [HsPat] -> HsPat+mkChildrenPat ps = mkCPAux ps []+  where mkCPAux :: [HsPat] -> [HsPat] -> HsPat+  	mkCPAux [] qs = HsPList $ reverse qs+  	mkCPAux (p:ps) qs = case p of+  		(HsPRPat s rps) -> mkCRP s ps (reverse rps ++ map HsRPPat qs)+  		_		-> mkCPAux ps (p:qs)+  		+  	mkCRP :: SrcLoc -> [HsPat] -> [HsRPat] -> HsPat+  	mkCRP s [] rps = HsPRPat s $ reverse rps+  	mkCRP s (p:ps) rps = case p of+  		(HsPRPat _ rqs) -> mkCRP s ps (reverse rqs ++ rps)+  		_ 		-> mkCRP s ps (HsRPPat p : rps)++-----------------------------------------------------------------------------+-- Check Expression Syntax++checkExpr :: HsExp -> P HsExp+checkExpr e = case e of+	HsVar _			  -> return e+	HsIPVar _		  -> return e+	HsCon _			  -> return e+	HsLit _			  -> return e+	HsInfixApp e1 op e2	  -> check2Exprs e1 e2 (flip HsInfixApp op)+	HsApp e1 e2		  -> check2Exprs e1 e2 HsApp+	HsNegApp e		  -> check1Expr e HsNegApp+	HsLambda loc ps e	  -> check1Expr e (HsLambda loc ps)+	HsLet bs e		  -> check1Expr e (HsLet bs)+	HsDLet bs e		  -> check1Expr e (HsDLet bs)+	HsWith e bs		  -> check1Expr e (flip HsWith bs)+	HsIf e1 e2 e3		  -> check3Exprs e1 e2 e3 HsIf+	HsCase e alts		  -> do+				     alts <- mapM checkAlt alts+				     e <- checkExpr e+				     return (HsCase e alts)+	HsDo stmts		  -> do+				     stmts <- mapM checkStmt stmts+				     return (HsDo stmts)+	HsMDo stmts		  -> do+				     stmts <- mapM checkStmt stmts+				     return (HsMDo stmts)+	HsTuple es		  -> checkManyExprs es HsTuple+	HsList es		  -> checkManyExprs es HsList+	HsParen e		  -> check1Expr e HsParen+	HsLeftSection e op	  -> check1Expr e (flip HsLeftSection op)+	HsRightSection op e	  -> check1Expr e (HsRightSection op)+	HsRecConstr c fields	  -> do+				     fields <- mapM checkField fields+				     return (HsRecConstr c fields)+	HsRecUpdate e fields	  -> do+				     fields <- mapM checkField fields+				     e <- checkExpr e+				     return (HsRecUpdate e fields)+	HsEnumFrom e		  -> check1Expr e HsEnumFrom+	HsEnumFromTo e1 e2	  -> check2Exprs e1 e2 HsEnumFromTo+	HsEnumFromThen e1 e2      -> check2Exprs e1 e2 HsEnumFromThen+	HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo+	HsListComp e stmts        -> do+				     stmts <- mapM checkStmt stmts+				     e <- checkExpr e+				     return (HsListComp e stmts)+	HsExpTypeSig loc e ty     -> do+				     e <- checkExpr e+				     return (HsExpTypeSig loc e ty)+	+	--Template Haskell+	HsReifyExp _		  -> return e+	HsBracketExp _		  -> return e+	HsSpliceExp _		  -> return e+	+	-- Hsx+	HsXTag s n attrs mattr cs -> do attrs <- mapM checkAttr attrs+					cs <- mapM checkExpr cs+			     		mattr <- maybe (return Nothing) +			      		  (\e -> checkExpr e >>= return . Just) +			      		  mattr					+					return $ HsXTag s n attrs mattr cs+	HsXETag s n attrs mattr	  -> do attrs <- mapM checkAttr attrs+			     		mattr <- maybe (return Nothing) +			      		  (\e -> checkExpr e >>= return . Just) +			      		  mattr					+					return $ HsXETag s n attrs mattr +	HsXPcdata _		  -> return e+	HsXExpTag e		  -> do e <- checkExpr e+					return $ HsXExpTag e+	-- Functor sugar+	HsFunctorUnit e	          -> do e <- checkExpr e+                                        return $ HsFunctorUnit e+	HsFunctorCall e	          -> do e <- checkExpr e+                                        return $ HsFunctorCall e+	_			  -> fail $ "Parse error in expression: " ++ show e++checkAttr :: HsXAttr -> P HsXAttr+checkAttr (HsXAttr n v) = do v <- checkExpr v+			     return $ HsXAttr n v++-- type signature for polymorphic recursion!!+check1Expr :: HsExp -> (HsExp -> a) -> P a+check1Expr e1 f = do+	e1 <- checkExpr e1+	return (f e1)++check2Exprs :: HsExp -> HsExp -> (HsExp -> HsExp -> a) -> P a+check2Exprs e1 e2 f = do+	e1 <- checkExpr e1+	e2 <- checkExpr e2+	return (f e1 e2)++check3Exprs :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> a) -> P a+check3Exprs e1 e2 e3 f = do+	e1 <- checkExpr e1+	e2 <- checkExpr e2+	e3 <- checkExpr e3+	return (f e1 e2 e3)++checkManyExprs :: [HsExp] -> ([HsExp] -> a) -> P a+checkManyExprs es f = do+	es <- mapM checkExpr es+	return (f es)++checkAlt :: HsAlt -> P HsAlt+checkAlt (HsAlt loc p galts bs) = do+	galts <- checkGAlts galts+	return (HsAlt loc p galts bs)++checkGAlts :: HsGuardedAlts -> P HsGuardedAlts+checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt+checkGAlts (HsGuardedAlts galts) = do+	galts <- mapM checkGAlt galts+	return (HsGuardedAlts galts)++checkGAlt :: HsGuardedAlt -> P HsGuardedAlt+checkGAlt (HsGuardedAlt loc g e) = check1Expr e (HsGuardedAlt loc g)++checkStmt :: HsStmt -> P HsStmt+checkStmt (HsGenerator loc p e) = check1Expr e (HsGenerator loc p)+checkStmt (HsQualifier e) = check1Expr e HsQualifier+checkStmt s@(HsLetStmt _) = return s++checkField :: HsFieldUpdate -> P HsFieldUpdate+checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n)++getGConName :: HsExp -> P HsQName+getGConName (HsCon n) = return n+getGConName (HsList []) = return list_cons_name+getGConName _ = fail "Expression in reification is not a name"++-----------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SrcLoc -> HsExp -> HsRhs -> HsBinds -> P HsDecl+checkValDef srcloc lhs rhs whereBinds =+    case isFunLhs lhs [] of+	 Just (f,es) -> do+			ps <- mapM checkPattern es+			return (HsFunBind [HsMatch srcloc f ps rhs whereBinds])+         Nothing     -> do+			lhs <- checkPattern lhs+			return (HsPatBind srcloc lhs rhs whereBinds)++-- A variable binding is parsed as an HsPatBind.++isFunLhs :: HsExp -> [HsExp] -> Maybe (HsName, [HsExp])+isFunLhs (HsInfixApp l (HsQVarOp (UnQual op)) r) es = Just (op, l:r:es)+isFunLhs (HsApp (HsVar (UnQual f)) e) es = Just (f, e:es)+isFunLhs (HsApp (HsParen f) e) es = isFunLhs f (e:es)+isFunLhs (HsApp f e) es = isFunLhs f (e:es)+isFunLhs _ _ = Nothing++-----------------------------------------------------------------------------+-- In a class or instance body, a pattern binding must be of a variable.++checkClassBody :: [HsDecl] -> P [HsDecl]+checkClassBody decls = do+	mapM_ checkMethodDef decls+	return decls++checkMethodDef :: HsDecl -> P ()+checkMethodDef (HsPatBind _ (HsPVar _) _ _) = return ()+checkMethodDef (HsPatBind loc _ _ _) =+	fail "illegal method definition" `atSrcLoc` loc+checkMethodDef _ = return ()++-----------------------------------------------------------------------------+-- Check that an identifier or symbol is unqualified.+-- For occasions when doing this in the grammar would cause conflicts.++checkUnQual :: HsQName -> P HsName+checkUnQual (Qual _ _) = fail "Illegal qualified name"+checkUnQual (UnQual n) = return n+checkUnQual (Special _) = fail "Illegal special name"++-----------------------------------------------------------------------------+-- Check that two xml tag names are equal+-- Could use Eq directly, but I am not sure whether <dom:name>...</name> +-- would be valid, in that case Eq won't work. TODO++checkEqNames :: HsXName -> HsXName -> P HsXName+checkEqNames n@(HsXName n1) (HsXName n2) +	| n1 == n2  = return n+	| otherwise = fail "names in matching xml tags are not equal"+checkEqNames n@(HsXDomName d1 n1) (HsXDomName d2 n2)+	| n1 == n2 && d1 == d2 = return n+	| otherwise = fail "names in matching xml tags are not equal"+checkEqNames _ _ = fail "names in matching xml tags are not equal"+++-----------------------------------------------------------------------------+-- Miscellaneous utilities++checkPrec :: Integer -> P Int+checkPrec i | 0 <= i && i <= 9 = return (fromInteger i)+checkPrec i | otherwise	       = fail ("Illegal precedence " ++ show i)++mkRecConstrOrUpdate :: HsExp -> [HsFieldUpdate] -> P HsExp+mkRecConstrOrUpdate (HsCon c) fs       = return (HsRecConstr c fs)+mkRecConstrOrUpdate e         fs@(_:_) = return (HsRecUpdate e fs)+mkRecConstrOrUpdate _         _        = fail "Empty record update"++-----------------------------------------------------------------------------+-- Reverse a list of declarations, merging adjacent HsFunBinds of the+-- same name and checking that their arities match.++checkRevDecls :: [HsDecl] -> P [HsDecl]+checkRevDecls = mergeFunBinds []+    where+	mergeFunBinds revDs [] = return revDs+	mergeFunBinds revDs (HsFunBind ms1@(HsMatch _ name ps _ _:_):ds1) =+		mergeMatches ms1 ds1+	    where+		arity = length ps+		mergeMatches ms' (HsFunBind ms@(HsMatch loc name' ps' _ _:_):ds)+		    | name' == name =+			if length ps' /= arity+			then fail ("arity mismatch for '" ++ prettyPrint name ++ "'")+			     `atSrcLoc` loc+			else mergeMatches (ms++ms') ds+		mergeMatches ms' ds = mergeFunBinds (HsFunBind ms':revDs) ds+	mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds+++---------------------------------------+-- Converting a complete page++pageFun :: SrcLoc -> HsExp -> HsDecl+pageFun loc e = HsPatBind loc namePat rhs (HsBDecls [])+    where namePat = HsPVar $ HsIdent "page"+    	  rhs = HsUnGuardedRhs e++mkPage :: HsModule -> SrcLoc -> HsExp -> P HsModule+mkPage (HsModule src prags md exps imps decls) loc xml = do+	let page = pageFun loc xml+	return $ HsModule src prags md exps imps (decls ++ [page])+	+mkPageModule :: HsExp -> P HsModule+mkPageModule xml = do +	do loc <- case xml of +	 	   HsXTag l _ _ _ _ -> return l+	 	   HsXETag l _ _ _  -> return l+	 	   _ -> fail "Will not happen since mkPageModule is only called on XML expressions"+	   mod <- getModuleName+	   return $ (HsModule +	  	      loc+	  	      []+	  	      (Module mod)+	  	      (Just [HsEVar $ UnQual $ HsIdent "page"])+	  	      []+	  	      [pageFun loc xml])++---------------------------------------+-- Handle dash-identifiers++mkDVar :: [String] -> String+mkDVar = concat . intersperse "-"++mkDVarExpr :: [String] -> HsExp+mkDVarExpr = foldl1 (\x y -> infixApp x (op $ sym "-") y) . map (var . name)++---------------------------------------+-- Combine adjacent for-alls. +--+-- A valid type must have one for-all at the top of the type, or of the fn arg types++mkHsTyForall :: Maybe [HsName] -> HsContext -> HsType -> HsType+mkHsTyForall mtvs []   ty = mk_forall_ty mtvs ty+mkHsTyForall mtvs ctxt ty = HsTyForall mtvs ctxt ty++-- mk_forall_ty makes a pure for-all type (no context)+mk_forall_ty (Just []) ty 			  = ty	-- Explicit for-all with no tyvars+mk_forall_ty mtvs1     (HsTyForall mtvs2 ctxt ty) = mkHsTyForall (mtvs1 `plus` mtvs2) ctxt ty+mk_forall_ty mtvs1     ty			  = HsTyForall mtvs1 [] ty++mtvs1       `plus` Nothing     = mtvs1+Nothing     `plus` mtvs2       = mtvs2 +(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
+ _darcs/pristine/Preprocessor/Hsx/Parser.ly view
@@ -0,0 +1,1175 @@+> {+> -----------------------------------------------------------------------------+> -- |+> -- Module      :  Preprocessor.Hsx.Parser+> -- Original    :  Language.Haskell.Parser+> -- Copyright   :  (c) Niklas Broberg 2004,+> -- 		    Original (c) Simon Marlow, Sven Panne 1997-2000+> -- License     :  BSD-style (see the file LICENSE.txt)+> --+> -- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+> -- Stability   :  experimental+> -- Portability :  portable+> --+> --+> -----------------------------------------------------------------------------+>+> module Preprocessor.Hsx.Parser (+>		parseModule, parseModuleWithMode,+>		ParseMode(..), defaultParseMode, ParseResult(..)) where+> +> import Preprocessor.Hsx.Syntax+> import Preprocessor.Hsx.ParseMonad+> import Preprocessor.Hsx.Lexer+> import Preprocessor.Hsx.ParseUtils+> }++-----------------------------------------------------------------------------+This module comprises a parser for Haskell 98 with the following extensions++* Multi-parameter type classes with functional dependencies+* Implicit parameters+* Pattern guards+* Mdo notation+* FFI+* HaRP+* HSP++Most of the code is blatantly stolen from the GHC module Preprocessor.Parser.+Some of the code for extensions is greatly influenced by GHC's internal parser+library, ghc/compiler/parser/Parser.y. +-----------------------------------------------------------------------------+Conflicts: 3 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).+	+1 for ambiguity in 'let ?x ...'+	the parser can't tell whether the ?x is the lhs of a normal binding or+	an implicit binding. Fortunately resolving as shift gives it the only+	sensible meaning, namely the lhs of an implicit binding.++-----------------------------------------------------------------------------++> %token+>	VARID 	 { VarId $$ }+>	QVARID 	 { QVarId $$ }+>	IDUPID	 { IDupVarId $$ }	-- duplicable implicit parameter ?x+>	ILINID	 { ILinVarId $$ }	-- linear implicit parameter %x+>	CONID	 { ConId $$ }+>	QCONID   { QConId $$ }+>	DVARID	 { DVarId $$ }		-- VARID containing dashes+>	VARSYM	 { VarSym $$ }+>	CONSYM	 { ConSym $$ }+>	QVARSYM	 { QVarSym $$ }+>	QCONSYM  { QConSym $$ }+>	INT	 { IntTok $$ }+>	RATIONAL { FloatTok $$ }+>	CHAR	 { Character $$ }+>	STRING   { StringTok $$ }+>	PRAGMA   { Pragma $$ }++Symbols++>	'('	{ LeftParen }+>	')'	{ RightParen }+>	'(#'	{ LeftHashParen }+>	'#)'	{ RightHashParen }+>	';'	{ SemiColon }+>	'{'	{ LeftCurly }+>	'}'	{ RightCurly }+>	vccurly { VRightCurly }			-- a virtual close brace+>	'['	{ LeftSquare }+>	']'	{ RightSquare }+>  	','	{ Comma }+>	'_'	{ Underscore }+>	'`'	{ BackQuote }++Reserved operators++>	'.'	{ Dot }+>	'..'	{ DotDot }+>	':'	{ Colon }+>	'::'	{ DoubleColon }+>	'='	{ Equals }+>	'\\'	{ Backslash }+>	'|'	{ Bar }+>	'<-'	{ LeftArrow }+>	'->'	{ RightArrow }+>	'@'	{ At }+>	'~'	{ Tilde }+>	'=>'	{ DoubleArrow }+>	'-'	{ Minus }+>	'!'	{ Exclamation }+>	'#'	{ Hash }++Harp++>	'[/'	{ RPOpen }+>	'/]'	{ RPClose }+>	'(/'	{ RPSeqOpen }+>	'/)'	{ RPSeqClose }+>	'*'	{ RPStar }+>	'*!'	{ RPStarG }+>	'+'	{ RPPlus }+>	'+!'	{ RPPlusG }+>	'?'	{ RPOpt }+>	'?!'	{ RPOptG }+>	'rp|'	{ RPEither } -- '|' already taken+>	'@:'	{ RPCAt }++Template Haskell++>	IDSPLICE 	{ THIdEscape $$ }+>	'$('		{ THParenEscape }+>	'[|'		{ THExpQuote }+>	'[p|'		{ THPatQuote }+>	'[t|'		{ THTypQuote }+>	'[d|'		{ THDecQuote }+>	'|]'		{ THCloseQuote }+>	'reifyDecl'	{ THReifyDecl }+>	'reifyType'	{ THReifyType }+>	'reifyFixity'	{ THReifyFixity }++Hsx++>	PCDATA		{ XPcdata $$ }+>	'<'		{ XStdTagOpen }+>	'</'		{ XCloseTagOpen }+>	'<%'		{ XCodeTagOpen }+>	'>'		{ XStdTagClose }+>	'/>'		{ XEmptyTagClose }+>	'%>'		{ XCodeTagClose }++FFI++>	'foreign'	{ KW_Foreign }+>	'export'	{ KW_Export }+>	'safe'		{ KW_Safe }+>	'unsafe'	{ KW_Unsafe }+>	'threadsafe'	{ KW_Threadsafe }+>	'stdcall'	{ KW_StdCall }+>	'ccall'		{ KW_CCall }++Reserved Ids++>	'as'		{ KW_As }+>	'case'		{ KW_Case }+>	'class'		{ KW_Class }+>	'data'		{ KW_Data }+>	'default'	{ KW_Default }+>	'deriving'	{ KW_Deriving }+>	'dlet'		{ KW_DLet }	-- implicit parameter binding clause+>	'do'		{ KW_Do }+>	'else'		{ KW_Else }+>	'forall'	{ KW_Forall }	-- universal/existential qualification+>	'hiding'	{ KW_Hiding }+>	'if'		{ KW_If }+>	'import'	{ KW_Import }+>	'in'		{ KW_In }+>	'infix'		{ KW_Infix }+>	'infixl'	{ KW_InfixL }+>	'infixr'	{ KW_InfixR }+>	'instance'	{ KW_Instance }+>	'let'		{ KW_Let }+>	'mdo'		{ KW_MDo }+>	'module'	{ KW_Module }+>	'newtype'	{ KW_NewType }+>	'of'		{ KW_Of }+>	'then'		{ KW_Then }+>	'type'		{ KW_Type }+>	'where'		{ KW_Where }+>	'with'		{ KW_With }	-- implicit parameter binding clause+>	'qualified'	{ KW_Qualified }++> %monad { P }+> %lexer { lexer } { EOF }+> %name parse+> %tokentype { Token }+> %%++-----------------------------------------------------------------------------+HSP Pages++> page :: { HsModule }+>	: topxml				{% mkPageModule $1 }+>	| '<%' module '%>' srcloc topxml 	{% mkPage $2 $4 $5 }+>	| module		{ $1 }++> topxml :: { HsExp }+>	: srcloc '<' name attrs mattr '>' children '</' name '>'	{% do { n <- checkEqNames $3 $9;+>										let { cn = reverse $7;+>										      as = reverse $4; };+>										return $ HsXTag $1 n as $5 cn } }+>	| srcloc '<' name attrs mattr '/>'				{ HsXETag $1 $3 (reverse $4) $5 }+++-----------------------------------------------------------------------------+Module Header++> module :: { HsModule }+>	: srcloc pragmas 'module' modid maybeexports 'where' body+>		{ HsModule $1 $2 $4 $5 (fst $7) (snd $7) }+>	| srcloc pragmas body+>		{ HsModule $1 $2 main_mod (Just [HsEVar (UnQual main_name)])+>							(fst $3) (snd $3) }++> pragmas :: { [HsPragma] }+>	: PRAGMA pragmas	{ HsPragma $1 : $2 }+>	| {- empty -}		{ [] }++> 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 '=' ctype+>			{ HsTypeDecl $1 (fst $3) (snd $3) $5 }+>	| srcloc 'data' ctype constrs0 deriving+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsDataDecl $1 cs c t (reverse $4) $5) } }+>	| srcloc 'data' ctype 'where' gadtlist+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsGDataDecl $1 cs c t (reverse $5)) } }+>	| srcloc 'newtype' ctype '=' constr deriving+>			{% do { (cs,c,t) <- checkDataHeader $3;+>				return (HsNewTypeDecl $1 cs c t $5 $6) } }++A class declaration may include functional dependencies.+>	| srcloc 'class' ctype fds optcbody+>			{% do { (cs,c,vs) <- checkClassHeader $3;+>				return (HsClassDecl $1 cs c vs $4 $5) } }+>	| srcloc 'instance' ctype optvaldefs+>			{% do { (cs,c,ts) <- checkInstHeader $3;+>				return (HsInstDecl $1 cs c ts $4) } }+>	| srcloc 'default' '(' typelist ')'+>			{ HsDefaultDecl $1 $4 }+>	| srcloc '$(' exp ')'+>                        {% do { e <- checkExpr $3;+>                                return $ HsSpliceDecl $1 $ HsParenSplice e } }+>+>	| srcloc 'foreign' 'import' callconv safety fspec+>			{ let (s,n,t) = $6 in HsForImp $1 $4 $5 s n t }+>	| srcloc 'foreign' 'export' callconv fspec+>			{ let (s,n,t) = $5 in HsForExp $1 $4 s n t }+>       | 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 }++Binding can be either of implicit parameters, or it can be a normal sequence+of declarations. The two kinds cannot be mixed within the same block of+binding.++> binds :: { HsBinds }+>	: decllist			{ HsBDecls $1 }+>	| '{' ipbinds '}'		{ HsIPBinds $2 }+>	| open ipbinds close		{ HsIPBinds $2 }++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] } }++-----------------------------------------------------------------------------+FFI++> callconv :: { HsCallConv }+> 	   : 'stdcall'			{ StdCall }+>	   | 'ccall'			{ CCall }++> safety :: { HsSafety }+>	 : 'safe'			{ PlaySafe False }+>	 | 'unsafe'			{ PlayRisky }+> 	 | 'threadsafe'			{ PlaySafe True }+>	 | {- empty -}			{ PlaySafe False }++> fspec :: { (String, HsName, HsType) }+>	: STRING var_no_safety '::' dtype		{ ($1, $2, $4) }+>	|        var_no_safety '::' dtype		{ ("", $1, $3) }++-----------------------------------------------------------------------------+Types++> dtype :: { HsType }+>	: btype				{ $1 }+>       | btype qtyconop dtype          { HsTyInfix $1 $2 $3 }+>       | btype qtyvarop dtype          { HsTyInfix $1 $2 $3 }+>	| btype '->' dtype		{ HsTyFun $1 $3 }++Implicit parameters can occur in normal types, as well as in contexts.++> type :: { HsType }+>	: ivar '::' dtype		{ HsTyPred $ HsIParam $1 $3 }+>	| dtype				{ $1 }++> btype :: { HsType }+>	: btype atype			{ HsTyApp $1 $2 }+>	| atype				{ $1 }++> atype :: { HsType }+>	: gtycon			{ HsTyCon $1 }+>	| tyvar				{ HsTyVar $1 }+>	| '(' types ')'			{ HsTyTuple Boxed (reverse $2) }+>	| '(#' types1 '#)'		{ HsTyTuple Unboxed (reverse $2) }+>	| '[' type ']'			{ HsTyApp list_tycon $2 }+>	| '(' ctype ')'			{ $2 }++> gtycon :: { HsQName }+>	: qconid			{ $1 }+>	| '(' ')'			{ unit_tycon_name }+>	| '(' '->' ')'			{ fun_tycon_name }+>	| '[' ']'			{ list_tycon_name }+>	| '(' commas ')'		{ tuple_tycon_name $2 }++These are for infix types++> qtyconop :: { HsQName }+>       : qconop                        { $1 }++++++(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 :: { HsType }+>	: 'forall' tyvars '.' ctype	{ mkHsTyForall (Just $2) [] $4 }+>	| context '=>' type		{ mkHsTyForall Nothing $1 $3 }+>	| type				{ $1 }++> context :: { HsContext }+>	: btype				{% checkContext $1 }++> types	:: { [HsType] }+>	: types1 ',' type		{ $3 : $1 }++> types1 :: { [HsType] }+>	: type				{ [$1] }+>	| types1 ',' type		{ $3 : $1 }++> simpletype :: { (HsName, [HsName]) }+>	: tycon tyvars			{ ($1,reverse $2) }++> tyvars :: { [HsName] }+>	: tyvars tyvar			{ $2 : $1 }+>	| {- empty -}			{ [] }++-----------------------------------------------------------------------------+Functional Dependencies++> fds :: { [HsFunDep] }+>	: {- empty -}			{ [] }+>	| '|' fds1			{ reverse $2 }++> fds1 :: { [HsFunDep] }+>	: fds1 ',' fd			{ $3 : $1 }+>	| fd				{ [$1] }++> fd :: { HsFunDep }+>	: tyvars '->' tyvars		{ HsFunDep (reverse $1) (reverse $3) }++-----------------------------------------------------------------------------+Datatype declarations++GADTs++> gadtlist :: { [HsGadtDecl] }+>	: '{' gadtconstrs1 '}'			{ $2 }+>	| open gadtconstrs1 close		{ $2 }++> gadtconstrs1 :: { [HsGadtDecl] }+>	: optsemis gadtconstrs optsemis		{ $2 }++> gadtconstrs :: { [HsGadtDecl] }+>	: gadtconstrs semis gadtconstr		{ $3 : $1 }+>	| gadtconstr 				{ [$1] }++> gadtconstr :: { HsGadtDecl }+>	: srcloc qcon '::' ctype		{% do { c <- checkUnQual $2;+>							return $ HsGadtDecl $1 c $4 } }++> constrs0 :: { [HsQualConDecl] }+>	: {- empty -}			{ [] }+>	| '=' constrs			{ $2 }++> constrs :: { [HsQualConDecl] }+>	: constrs '|' constr		{ $3 : $1 }+>	| constr			{ [$1] }++> constr :: { HsQualConDecl }+>	: srcloc forall context '=>' constr1	{ HsQualConDecl $1 $2 $3 $5 }+>	| srcloc forall constr1			{ HsQualConDecl $1 $2 [] $3 }++> forall :: { [HsName] }+>	: 'forall' tyvars '.'		{ $2 }+>	| {- empty -}			{ [] }++> constr1 :: { HsConDecl }+>	: scontype			{ HsConDecl (fst $1) (snd $1) }+>	| sbtype conop sbtype		{ HsConDecl $2 [$1,$3] }+>	| con '{' '}'			{ HsRecDecl $1 [] }+>	| con '{' fielddecls '}' 	{ HsRecDecl $1 (reverse $3) }++> 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 }+>	: ctype				{ 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++No implicit parameters in the where clause of a class declaration.+> 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 }++May bind implicit parameters+> optwhere :: { HsBinds }+>	: 'where' binds			{ $2 }+>	| {- empty -}			{ HsBDecls [] }++> rhs	:: { HsRhs }+>	: '=' exp			{% do { e <- checkExpr $2;+>						return (HsUnGuardedRhs e) } }+>	| gdrhs				{ HsGuardedRhss  (reverse $1) }++> gdrhs :: { [HsGuardedRhs] }+>	: gdrhs gdrh			{ $2 : $1 }+>	| gdrh				{ [$1] }++Guards may contain patterns, hence quals instead of exp.+> gdrh :: { HsGuardedRhs }+>	: srcloc '|' quals '=' exp	{% do { e <- checkExpr $5;+>						return (HsGuardedRhs $1 (reverse $3) 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 }+>	| exp0b 'with' ipbinding	{ HsWith $1 $3 }  -- implicit parameters+>	| 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 }+>	| dvarexp			{ $1 }+>	| exp10b			{ $1 }++> exp10a :: { HsExp }+>	: '\\' srcloc apats '->' exp	{ HsLambda $2 (reverse $3) $5 }+A let may bind implicit parameters+>  	| 'let' binds 'in' exp		{ HsLet $2 $4 }+>	| 'dlet' ipbinding 'in' exp	{ HsDLet $2 $4 }+>	| 'if' exp 'then' exp 'else' exp { HsIf $2 $4 $6 }++> exp10b :: { HsExp }+>	: 'case' exp 'of' altslist	{ HsCase $2 $4 }+>	| '-' fexp			{ HsNegApp $2 }+>  	| 'do' stmtlist			{ HsDo $2 }+>  	| 'mdo' stmtlist		{ HsMDo $2 }+>	| reifyexp			{ HsReifyExp $1 }+>	| 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) } }+>	| qvar '@:' aexp		{% do { n <- checkUnQual $1;+>						return (HsCAsRP n $3) } }+>	| '~' aexp			{ HsIrrPat $2 }+>	| '#' aexp			{ HsFunctorUnit $2 }+>	| '!' aexp			{ HsFunctorCall $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) }+>	| aexp1 '*'			{ HsStarRP $1 }+>	| aexp1 '*!'			{ HsStarGRP $1 }+>	| aexp1 '+'			{ HsPlusRP $1 }+>	| aexp1 '+!'			{ HsPlusGRP $1 }+>	| aexp1 '?'			{ HsOptRP $1 }+>	| aexp1 '?!'			{ HsOptGRP $1 }+>  	| 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.+An implicit parameter can be used as an expression.++> aexp2	:: { HsExp }+>	: ivar				{ HsIPVar $1 }+>	| 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 }+>	| '(' erpats ')'		{ $2 }+>	| '(/' rpats '/)'		{ HsSeqRP $ reverse $2 }+>	| srcloc '[/' rpats '/]'	{ HsRPats $1 $ reverse $3 }+>	| xml				{ $1 }++Template Haskell+>	| IDSPLICE			{ HsSpliceExp $ HsIdSplice $1 }+>	| '$(' exp ')'			{% do { e <- checkExpr $2;+>						return $ HsSpliceExp $ HsParenSplice e } }+>	| '[|' exp '|]'			{% do { e <- checkExpr $2;+>						return $ HsBracketExp $ HsExpBracket e } }+>	| '[p|' exp0 '|]'		{% do { p <- checkPattern $2;+>						return $ HsBracketExp $ HsPatBracket p } }+>	| '[t|' ctype '|]'		{ HsBracketExp $ HsTypeBracket $2 }+>	| '[d|' topdecls '|]'		{ HsBracketExp $ HsDeclBracket $2 }++> reifyexp :: { HsReify }+>	: 'reifyDecl' gtycon		{ HsReifyDecl $2 }+>	| 'reifyDecl' qvar		{ HsReifyDecl $2 }+>	| 'reifyType' qcname		{ HsReifyType $2 }+>	| 'reifyFixity' qcname		{ HsReifyFixity $2 }++> qcname :: { HsQName }+>	: qvar				{ $1 }+>	| gcon				{% getGConName $1 }+End Template Haskell++> commas :: { Int }+>	: commas ','			{ $1 + 1 }+>	| ','				{ 1 }++> texps :: { [HsExp] }+>	: texps ',' exp			{ $3 : $1 }+>	| exp ',' exp			{ [$3,$1] }++-----------------------------------------------------------------------------+Harp Extensions++> rpats :: { [HsExp] }+>	: rpats ',' rpat		{ $3 : $1 }+>	| rpat				{ [$1] }++> rpat :: { HsExp }+>	: erpats			{ $1 }+>	| exp 				{ $1 }++Either patterns are left associative+> erpats :: { HsExp }+>	: exp 'rp|' erpats		{ HsEitherRP $1 $3 }+>	| exp 'rp|' exp			{ HsEitherRP $1 $3 }++-----------------------------------------------------------------------------+Hsx Extensions++> xml :: { HsExp }+>	: srcloc '<' name attrs mattr '>' children '</' name '>'	{% do { n <- checkEqNames $3 $9;+>										let { cn = reverse $7;+>										      as = reverse $4; };+>										return $ HsXTag $1 n as $5 cn } }+>	| srcloc '<' name attrs mattr '/>'				{ HsXETag $1 $3 (reverse $4) $5 }+>	| '<%' exp '%>'							{ HsXExpTag $2 }++> children :: { [HsExp] }+>	: children child		{ $2 : $1 }+>	| {- empty -}			{ [] }++> child :: { HsExp }+>	: PCDATA			{ HsXPcdata $1 }+>	| srcloc '[/' rpats '/]'	{ HsRPats $1 $ reverse $3 }+>	| xml				{ $1 }++> name :: { HsXName }+>	: xmlname ':' xmlname		{ HsXDomName $1 $3 }+>	| xmlname			{ HsXName $1 }++> xmlname :: { String }+>	: VARID				{ $1 }+>	| CONID				{ $1 }+>	| DVARID			{ mkDVar $1 }+>	| 'type'			{ "type" }+>	| 'class'			{ "class" }++> attrs :: { [HsXAttr] }+>	: attrs attr			{ $2 : $1 }+>	| {- empty -}			{ [] }++> attr :: { HsXAttr }+>	: name '=' aexp			{ HsXAttr $1 $3 }++> mattr :: { Maybe HsExp }+>	: aexp				{ Just $1 }+>	| {-empty-}			{ Nothing }++Turning dash variables into infix expressions with '-'+> dvarexp :: { HsExp }+>	  : DVARID			{ mkDVarExpr $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' binds			{ 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] }++A guard can be a pattern guard, hence quals instead of exp0.+> gdpat	:: { HsGuardedAlt }+>	: srcloc '|' quals '->' exp	{ HsGuardedAlt $1 (reverse $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 }++A let statement may bind implicit parameters.+> stmts :: { [HsStmt] }+>	: 'let' binds ';' 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 }++-----------------------------------------------------------------------------+Implicit parameter bindings++> ipbinding :: { [HsIPBind] }+>	: '{' ipbinds '}'		{ $2 }+>	| open ipbinds close		{ $2 }++> ipbinds :: { [HsIPBind] }+> 	: optsemis ipbinds1 optsemis	{ reverse $2 }++> ipbinds1 :: { [HsIPBind] }+>	: ipbinds1 semis ipbind		{ $3 : $1 }+>	| ipbind			{ [$1] }++> ipbind :: { HsIPBind }+>	: srcloc ivar '=' exp		{ HsIPBind $1 $2 $4 }++-----------------------------------------------------------------------------+Variables, Constructors and Operators.++> gcon :: { HsExp }+>  	: '(' ')'		{ unit_con }+>	| '[' ']'		{ HsList [] }+>	| '(' commas ')'	{ tuple_con $2 }+>  	| qcon			{ HsCon $1 }++> var 	:: { HsName }+>	: varid			{ $1 }+>	| '(' varsym ')'	{ $2 }++> var_no_safety :: { HsName }+>		: varid_no_safety	{ $1 }+>		| '(' varsym ')'	{ $2 }++> qvar 	:: { HsQName }+>	: qvarid		{ $1 }+>	| '(' qvarsym ')'	{ $2 }++Implicit parameter+> ivar 	:: { HsIPName }+>	: ivarid		{ $1 }++> 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_no_safety :: { HsName }+>	: VARID			{ HsIdent $1 }+>	| 'as'			{ as_name }+>	| 'qualified'		{ qualified_name }+>	| 'hiding'		{ hiding_name }+>	| 'export'		{ export_name }+>	| 'stdcall'		{ stdcall_name }+>	| 'ccall'		{ ccall_name }++> varid :: { HsName }+>	: varid_no_safety	{ $1 }+>	| 'safe'		{ safe_name }+>	| 'unsafe'		{ unsafe_name }+>	| 'threadsafe'		{ threadsafe_name }+++Implicit parameter+> ivarid :: { HsIPName }+>	: IDUPID		{ HsIPDup $1 }+>	| ILINID		{ HsIPLin $1 }++> 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 }+>	| '-'			{ minus_name }+>	| '!'			{ pling_name }+>	| '.'			{ dot_name }++> varsymm :: { HsName } -- varsym not including '-'+>	: VARSYM		{ HsSymbol $1 }+>	| '!'			{ pling_name }+>	| '.'			{ dot_name }++> 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 }++> qtyvarop :: { HsQName }+> qtyvarop : '`' tyvar '`'       { UnQual $2 }+>          | tyvarsym            { UnQual $1 }++> tyvarsym :: { HsName }+> tyvarsym : VARSYM              { HsSymbol $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+> }
+ _darcs/pristine/Preprocessor/Hsx/Pretty.hs view
@@ -0,0 +1,986 @@+{-# OPTIONS_GHC -w #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Pretty+-- Original    :  Language.Haskell.Pretty+-- Copyright   :  (c) Niklas Broberg 2004,+-- 		  (c) The GHC Team, Noel Winstanley 1997-2000+-- License     :  BSD-style (see the file LICENSE.txt)+--+-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Pretty printer for Haskell with extensions.+--+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Pretty (+		-- * Pretty printing+		Pretty,+		prettyPrintStyleMode, prettyPrintWithMode, prettyPrint,+		-- * Pretty-printing styles (from "Text.PrettyPrint.HughesPJ")+		P.Style(..), P.style, P.Mode(..),+		-- * Haskell formatting modes+		PPHsMode(..), Indent, PPLayout(..), defaultMode) where++import Preprocessor.Hsx.Syntax++import qualified Text.PrettyPrint as P++infixl 5 $$$++-----------------------------------------------------------------------------++-- | Varieties of layout we can use.+data PPLayout = PPOffsideRule	-- ^ classical layout+	      | PPSemiColon	-- ^ classical layout made explicit+	      | PPInLine	-- ^ inline decls, with newlines between them+	      | PPNoLayout	-- ^ everything on a single line+	      deriving Eq++type Indent = Int++-- | Pretty-printing parameters.+--+-- /Note:/ the 'onsideIndent' must be positive and less than all other indents.+data PPHsMode = PPHsMode {+				-- | indentation of a class or instance+		classIndent :: Indent,+				-- | indentation of a @do@-expression+		doIndent :: Indent,+				-- | indentation of the body of a+				-- @case@ expression+		caseIndent :: Indent,+				-- | indentation of the declarations in a+				-- @let@ expression+		letIndent :: Indent,+				-- | indentation of the declarations in a+				-- @where@ clause+		whereIndent :: Indent,+				-- | indentation added for continuation+				-- lines that would otherwise be offside+		onsideIndent :: Indent,+				-- | blank lines between statements?+		spacing :: Bool,+				-- | Pretty-printing style to use+		layout :: PPLayout,+				-- | add GHC-style @LINE@ pragmas to output?+		linePragmas :: Bool,+				-- | not implemented yet+		comments :: Bool+		}++-- | The default mode: pretty-print using the offside rule and sensible+-- defaults.+defaultMode :: PPHsMode+defaultMode = PPHsMode{+		      classIndent = 8,+		      doIndent = 3,+		      caseIndent = 4,+		      letIndent = 4,+		      whereIndent = 6,+		      onsideIndent = 2,+		      spacing = True,+		      layout = PPOffsideRule,+		      linePragmas = False,+		      comments = True+		      }++-- | Pretty printing monad+newtype DocM s a = DocM (s -> a)++instance Functor (DocM s) where+	 fmap f xs = do x <- xs; return (f x)++instance Monad (DocM s) where+	(>>=) = thenDocM+	(>>) = then_DocM+	return = retDocM++{-# INLINE thenDocM #-}+{-# INLINE then_DocM #-}+{-# INLINE retDocM #-}+{-# INLINE unDocM #-}+{-# INLINE getPPEnv #-}++thenDocM :: DocM s a -> (a -> DocM s b) -> DocM s b+thenDocM m k = DocM $ (\s -> case unDocM m $ s of a -> unDocM (k a) $ s)++then_DocM :: DocM s a -> DocM s b -> DocM s b+then_DocM m k = DocM $ (\s -> case unDocM m $ s of _ -> unDocM k $ s)++retDocM :: a -> DocM s a+retDocM a = DocM (\_s -> a)++unDocM :: DocM s a -> (s -> a)+unDocM (DocM f) = f++-- all this extra stuff, just for this one function.+getPPEnv :: DocM s s+getPPEnv = DocM id++-- So that pp code still looks the same+-- this means we lose some generality though++-- | The document type produced by these pretty printers uses a 'PPHsMode'+-- environment.+type Doc = DocM PPHsMode P.Doc++-- | Things that can be pretty-printed, including all the syntactic objects+-- in "Preprocessor.Syntax".+class Pretty a where+	-- | Pretty-print something in isolation.+	pretty :: a -> Doc+	-- | Pretty-print something in a precedence context.+	prettyPrec :: Int -> a -> Doc+	pretty = prettyPrec 0+	prettyPrec _ = pretty++-- The pretty printing combinators++empty :: Doc+empty = return P.empty++nest :: Int -> Doc -> Doc+nest i m = m >>= return . P.nest i+++-- Literals++text, ptext :: String -> Doc+text = return . P.text+ptext = return . P.text++char :: Char -> Doc+char = return . P.char++int :: Int -> Doc+int = return . P.int++integer :: Integer -> Doc+integer = return . P.integer++float :: Float -> Doc+float = return . P.float++double :: Double -> Doc+double = return . P.double++rational :: Rational -> Doc+rational = return . P.rational++-- Simple Combining Forms++parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc+parens d = d >>= return . P.parens+brackets d = d >>= return . P.brackets+braces d = d >>= return . P.braces+quotes d = d >>= return . P.quotes+doubleQuotes d = d >>= return . P.doubleQuotes++parensIf :: Bool -> Doc -> Doc+parensIf True = parens+parensIf False = id++-- Constants++semi,comma,colon,space,equals :: Doc+semi = return P.semi+comma = return P.comma+colon = return P.colon+space = return P.space+equals = return P.equals++lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc+lparen = return  P.lparen+rparen = return  P.rparen+lbrack = return  P.lbrack+rbrack = return  P.rbrack+lbrace = return  P.lbrace+rbrace = return  P.rbrace++-- Combinators++(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc+aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}+aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}+aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}+aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}++hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc+hcat dl = sequence dl >>= return . P.hcat+hsep dl = sequence dl >>= return . P.hsep+vcat dl = sequence dl >>= return . P.vcat+sep dl = sequence dl >>= return . P.sep+cat dl = sequence dl >>= return . P.cat+fsep dl = sequence dl >>= return . P.fsep+fcat dl = sequence dl >>= return . P.fcat++-- Some More++hang :: Doc -> Int -> Doc -> Doc+hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}++-- Yuk, had to cut-n-paste this one from Pretty.hs+punctuate :: Doc -> [Doc] -> [Doc]+punctuate _ []     = []+punctuate p (d1:ds) = go d1 ds+                   where+                     go d [] = [d]+                     go d (e:es) = (d <> p) : go e es++-- | render the document with a given style and mode.+renderStyleMode :: P.Style -> PPHsMode -> Doc -> String+renderStyleMode ppStyle ppMode d = P.renderStyle ppStyle . unDocM d $ ppMode++-- | render the document with a given mode.+renderWithMode :: PPHsMode -> Doc -> String+renderWithMode = renderStyleMode P.style++-- | render the document with 'defaultMode'.+render :: Doc -> String+render = renderWithMode defaultMode++-- | pretty-print with a given style and mode.+prettyPrintStyleMode :: Pretty a => P.Style -> PPHsMode -> a -> String+prettyPrintStyleMode ppStyle ppMode = renderStyleMode ppStyle ppMode . pretty++-- | pretty-print with the default style and a given mode.+prettyPrintWithMode :: Pretty a => PPHsMode -> a -> String+prettyPrintWithMode = prettyPrintStyleMode P.style++-- | pretty-print with the default style and 'defaultMode'.+prettyPrint :: Pretty a => a -> String+prettyPrint = prettyPrintWithMode defaultMode++fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float ->+		      (P.TextDetails -> a -> a) -> a -> Doc -> a+fullRenderWithMode ppMode m i f fn e mD =+		   P.fullRender m i f fn e $ (unDocM mD) ppMode+++fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a)+	      -> a -> Doc -> a+fullRender = fullRenderWithMode defaultMode++-------------------------  Pretty-Print a Module --------------------+instance Pretty HsModule where+	pretty (HsModule pos prags m mbExports imp decls) =+		markLine pos $+		topLevel (ppHsModuleHeader prags m mbExports)+			 (map pretty imp ++ map pretty decls)++--------------------------  Module Header ------------------------------+ppHsModuleHeader :: [HsPragma] -> Module -> Maybe [HsExportSpec] ->  Doc+ppHsModuleHeader prags m mbExportList = mySep $ prags' ++ [+	text "module",+	pretty m,+	maybePP (parenList . map pretty) mbExportList,+	text "where"]+    where prags' = map (\(HsPragma s) -> text $ "{-#" ++ s ++ "#-}") prags++instance Pretty Module where+	pretty (Module modName) = text modName++instance Pretty HsExportSpec where+	pretty (HsEVar name)		    = pretty name+	pretty (HsEAbs name)		    = pretty name+	pretty (HsEThingAll name)	    = pretty name <> text "(..)"+	pretty (HsEThingWith name nameList) =+		pretty name <> (parenList . map pretty $ nameList)+	pretty (HsEModuleContents m)        = text "module" <+> pretty m++instance Pretty HsImportDecl where+	pretty (HsImportDecl pos m qual mbName mbSpecs) =+		markLine pos $+		mySep [text "import",+		       if qual then text "qualified" else empty,+		       pretty m,+		       maybePP (\m' -> text "as" <+> pretty m') mbName,+		       maybePP exports mbSpecs]+	    where+		exports (b,specList) =+			if b then text "hiding" <+> specs else specs+		    where specs = parenList . map pretty $ specList++instance Pretty HsImportSpec where+	pretty (HsIVar name)                = pretty name+	pretty (HsIAbs name)                = pretty name+	pretty (HsIThingAll name)           = pretty name <> text "(..)"+	pretty (HsIThingWith name nameList) =+		pretty name <> (parenList . map pretty $ nameList)++-------------------------  Declarations ------------------------------+instance Pretty HsDecl where+	pretty (HsTypeDecl loc name nameList htype) =+		blankline $+		markLine loc $+		mySep ( [text "type", pretty name]+			++ map pretty nameList+			++ [equals, pretty htype])++	pretty (HsDataDecl loc context name nameList constrList derives) =+		blankline $+		markLine loc $+		mySep ( [text "data", ppHsContext context, pretty name]+			++ map pretty nameList)+			<+> (myVcat (zipWith (<+>) (equals : repeat (char '|'))+						   (map pretty constrList))+			$$$ ppHsDeriving derives)++	pretty (HsGDataDecl loc context name nameList gadtList) =+		blankline $+		markLine loc $+		mySep ( [text "data", ppHsContext context, pretty name]+			++ map pretty nameList ++ [text "where"])+			$$$ ppBody classIndent (map pretty gadtList)++	pretty (HsNewTypeDecl pos context name nameList constr derives) =+		blankline $+		markLine pos $+		mySep ( [text "newtype", ppHsContext context, pretty name]+			++ map pretty nameList)+			<+> equals <+> (pretty constr $$$ ppHsDeriving derives)++	--m{spacing=False}+	-- special case for empty class declaration+	pretty (HsClassDecl pos context name nameList fundeps []) =+		blankline $+		markLine pos $+		mySep ( [text "class", ppHsContext context, pretty name]+			++ map pretty nameList ++ [ppFunDeps fundeps])+	pretty (HsClassDecl pos context name nameList fundeps declList) =+		blankline $+		markLine pos $+		mySep ( [text "class", ppHsContext context, pretty name]+			++ map pretty nameList ++ [ppFunDeps fundeps, text "where"])+		$$$ ppBody classIndent (map pretty declList)++	-- m{spacing=False}+	-- special case for empty instance declaration+	pretty (HsInstDecl pos context name args []) =+		blankline $+		markLine pos $+		mySep ( [text "instance", ppHsContext context, pretty name]+			++ map ppHsAType args)+	pretty (HsInstDecl pos context name args declList) =+		blankline $+		markLine pos $+		mySep ( [text "instance", ppHsContext context, pretty name]+			++ map ppHsAType args ++ [text "where"])+		$$$ ppBody classIndent (map pretty declList)++	pretty (HsDefaultDecl pos htypes) =+		blankline $+		markLine pos $+		text "default" <+> parenList (map pretty htypes)++        pretty (HsSpliceDecl pos splice) =+		blankline $+		markLine pos $+                pretty splice++	pretty (HsTypeSig pos nameList qualType) =+		blankline $+		markLine pos $+		mySep ((punctuate comma . map pretty $ nameList)+		      ++ [text "::", pretty qualType])++	pretty (HsFunBind matches) =+		foldr ($$$) empty (map pretty matches)++	pretty (HsPatBind pos pat rhs whereBinds) =+		markLine pos $+		myFsep [pretty pat, pretty rhs] $$$ ppWhere whereBinds++	pretty (HsInfixDecl pos assoc prec opList) =+		blankline $+		markLine pos $+		mySep ([pretty assoc, int prec]+		       ++ (punctuate comma . map pretty $ opList))++	pretty (HsForImp pos cconv saf str name typ) =+		blankline $+		markLine pos $+		mySep [text "foreign import", pretty cconv, pretty saf, +                       text (show str), pretty name, text "::", pretty typ]++	pretty (HsForExp pos cconv str name typ) =+		blankline $+		markLine pos $+		mySep [text "foreign export", pretty cconv,+                       text (show str), pretty name, text "::", pretty typ]++instance Pretty HsAssoc where+	pretty HsAssocNone  = text "infix"+	pretty HsAssocLeft  = text "infixl"+	pretty HsAssocRight = text "infixr"++instance Pretty HsMatch where+	pretty (HsMatch pos f ps rhs whereBinds) =+		markLine pos $+		myFsep (lhs ++ [pretty rhs])+		$$$ ppWhere whereBinds+	    where+		lhs = case ps of+			l:r:ps' | isSymbolName f ->+				let hd = [pretty l, ppHsName f, pretty r] in+				if null ps' then hd+				else parens (myFsep hd) : map (prettyPrec 2) ps'+			_ -> pretty f : map (prettyPrec 2) ps++ppWhere :: HsBinds -> Doc+ppWhere (HsBDecls []) = empty+ppWhere (HsBDecls l)  = nest 2 (text "where" $$$ ppBody whereIndent (map pretty l))+ppWhere (HsIPBinds b) = nest 2 (text "where" $$$ ppBody whereIndent (map pretty b))++------------------------- FFI stuff -------------------------------------+instance Pretty HsSafety where+	pretty PlayRisky	= text "unsafe"+	pretty (PlaySafe b)	= text $ if b then "threadsafe" else "safe"++instance Pretty HsCallConv where+ 	pretty StdCall 	= text "stdcall"+	pretty CCall	= text "ccall"++------------------------- Data & Newtype Bodies -------------------------+instance Pretty HsQualConDecl where+	pretty (HsQualConDecl _pos tvs ctxt con) =+		myFsep [ppForall (Just tvs), ppHsContext ctxt, pretty con]++instance Pretty HsGadtDecl where+	pretty (HsGadtDecl _pos name ty) =+		myFsep [pretty name, text "::", pretty ty]++instance Pretty HsConDecl where+	pretty (HsRecDecl name fieldList) =+		pretty name <> (braceList . map ppField $ fieldList)++	pretty (HsConDecl name@(HsSymbol _) [l, r]) =+		myFsep [prettyPrec prec_btype l, ppHsName name, +			prettyPrec prec_btype r]+	pretty (HsConDecl name typeList) =+		mySep $ ppHsName name : map (prettyPrec prec_atype) typeList++ppField :: ([HsName],HsBangType) -> Doc+ppField (names, ty) =+	myFsepSimple $ (punctuate comma . map pretty $ names) +++		       [text "::", pretty ty]++instance Pretty HsBangType where+	prettyPrec _ (HsBangedTy ty) = char '!' <> ppHsAType ty+	prettyPrec p (HsUnBangedTy ty) = prettyPrec p ty++ppHsDeriving :: [HsQName] -> Doc+ppHsDeriving []  = empty+ppHsDeriving [d] = text "deriving" <+> ppHsQName d+ppHsDeriving ds  = text "deriving" <+> parenList (map ppHsQName ds)++------------------------- Types -------------------------+{-+instance Pretty HsQualType where+	pretty (HsQualType context htype) =+		myFsep [ppHsContext context, pretty htype]+-}+ppHsBType :: HsType -> Doc+ppHsBType = prettyPrec prec_btype++ppHsAType :: HsType -> Doc+ppHsAType = prettyPrec prec_atype++-- precedences for types+prec_btype, prec_atype :: Int+prec_btype = 1	-- left argument of ->,+		-- or either argument of an infix data constructor+prec_atype = 2	-- argument of type or data constructor, or of a class++instance Pretty HsType where+	prettyPrec p (HsTyForall mtvs ctxt htype) = parensIf (p > 0) $+		myFsep [ppForall mtvs, ppHsContext ctxt, pretty htype]+	prettyPrec p (HsTyFun a b) = parensIf (p > 0) $+		myFsep [ppHsBType a, text "->", pretty b]+	prettyPrec _ (HsTyTuple bxd l) = +		let ds = map pretty l+		 in case bxd of +			Boxed   -> parenList ds+			Unboxed -> hashParenList ds+	prettyPrec p (HsTyApp a b)+		| a == list_tycon = brackets $ pretty b		-- special case+		| otherwise = parensIf (p > prec_btype) $+			myFsep [pretty a, ppHsAType b]+	prettyPrec _ (HsTyVar name) = pretty name+	prettyPrec _ (HsTyCon name) = pretty name+	prettyPrec _ (HsTyPred asst) = pretty asst+        prettyPrec _ (HsTyInfix a op b) = parens (myFsep [pretty op, parens (pretty a), parens (pretty b)])+++ppForall :: Maybe [HsName] -> Doc+ppForall Nothing   = empty+ppForall (Just []) = empty+ppForall (Just vs) = 	myFsep (text "forall" : map pretty vs ++ [char '.'])++------------------- Functional Dependencies -------------------+instance Pretty HsFunDep where+	pretty (HsFunDep from to) = +		myFsep $ map pretty from ++ [text "->"] ++ map pretty to+++ppFunDeps :: [HsFunDep] -> Doc+ppFunDeps [] = empty+ppFunDeps fds = myFsep $ (char '|':) . punctuate comma . map pretty $ fds++------------------------- Expressions -------------------------+instance Pretty HsRhs where+	pretty (HsUnGuardedRhs e) = equals <+> pretty e+	pretty (HsGuardedRhss guardList) = myVcat . map pretty $ guardList++instance Pretty HsGuardedRhs where+	pretty (HsGuardedRhs _pos guards ppBody) =+		myFsep $ [char '|'] ++ (punctuate comma . map pretty $ guards) ++ [equals, pretty ppBody]++instance Pretty HsLiteral where+	pretty (HsInt i)        = integer i+	pretty (HsChar c)       = text (show c)+	pretty (HsString s)     = text (show s)+	pretty (HsFrac r)       = double (fromRational r)+	-- GHC unboxed literals:+	pretty (HsCharPrim c)   = text (show c)           <> char '#'+	pretty (HsStringPrim s) = text (show s)           <> char '#'+	pretty (HsIntPrim i)    = integer i               <> char '#'+	pretty (HsFloatPrim r)  = float  (fromRational r) <> char '#'+	pretty (HsDoublePrim r) = double (fromRational r) <> text "##"++instance Pretty HsExp where+	pretty (HsLit l) = pretty l+	-- lambda stuff+	pretty (HsInfixApp a op b) = myFsep [pretty a, pretty op, pretty b]+	pretty (HsNegApp e) = myFsep [char '-', pretty e]+	pretty (HsApp a b) = myFsep [pretty a, pretty b]+	pretty (HsLambda _loc expList ppBody) = myFsep $+		char '\\' : map pretty expList ++ [text "->", pretty ppBody]+	-- keywords+	-- two cases for lets+	pretty (HsLet (HsBDecls declList) letBody) =+		ppLetExp declList letBody+	pretty (HsLet (HsIPBinds bindList) letBody) =+		ppLetExp bindList letBody+	pretty (HsDLet bindList letBody) =+		myFsep [text "dlet" <+> ppBody letIndent (map pretty bindList),+			text "in", pretty letBody]+	pretty (HsWith exp bindList) =+		pretty exp $$$ ppWith bindList+	pretty (HsIf cond thenexp elsexp) =+		myFsep [text "if", pretty cond,+			text "then", pretty thenexp,+			text "else", pretty elsexp]+	pretty (HsCase cond altList) =+		myFsep [text "case", pretty cond, text "of"]+		$$$ ppBody caseIndent (map pretty altList)+	pretty (HsDo stmtList) =+		text "do" $$$ ppBody doIndent (map pretty stmtList)+	pretty (HsMDo stmtList) =+		text "mdo" $$$ ppBody doIndent (map pretty stmtList)+	-- Constructors & Vars+	pretty (HsVar name) = pretty name+	pretty (HsIPVar ipname) = pretty ipname+	pretty (HsCon name) = pretty name+	pretty (HsTuple expList) = parenList . map pretty $ expList+	-- weird stuff+	pretty (HsParen e) = parens . pretty $ e+	pretty (HsLeftSection e op) = parens (pretty e <+> pretty op)+	pretty (HsRightSection op e) = parens (pretty op <+> pretty e)+	pretty (HsRecConstr c fieldList) =+		pretty c <> (braceList . map pretty $ fieldList)+	pretty (HsRecUpdate e fieldList) =+		pretty e <> (braceList . map pretty $ fieldList)+	-- patterns+	-- special case that would otherwise be buggy+	pretty (HsAsPat name (HsIrrPat e)) =+		myFsep [pretty name <> char '@', char '~' <> pretty e]+	pretty (HsAsPat name e) = hcat [pretty name, char '@', pretty e]+	pretty HsWildCard = char '_'+	pretty (HsIrrPat e) = char '~' <> pretty e+	-- Lists+	pretty (HsList list) =+		bracketList . punctuate comma . map pretty $ list+	pretty (HsEnumFrom e) =+		bracketList [pretty e, text ".."]+	pretty (HsEnumFromTo from to) =+		bracketList [pretty from, text "..", pretty to]+	pretty (HsEnumFromThen from thenE) =+		bracketList [pretty from <> comma, pretty thenE, text ".."]+	pretty (HsEnumFromThenTo from thenE to) =+		bracketList [pretty from <> comma, pretty thenE,+			     text "..", pretty to]+	pretty (HsListComp e stmtList) =+		bracketList ([pretty e, char '|']+			     ++ (punctuate comma . map pretty $ stmtList))+	pretty (HsExpTypeSig _pos e ty) =+		myFsep [pretty e, text "::", pretty ty]+	-- Template Haskell+	pretty (HsReifyExp r) = pretty r+	pretty (HsBracketExp b) = pretty b+	pretty (HsSpliceExp s) = pretty s+	-- regular patterns+	pretty (HsRPats _ rs) = +		myFsep $ text "[/" : map pretty rs ++ [text "/]"]+	pretty (HsSeqRP rs) =+		myFsep $ text "(/" : map pretty rs ++ [text "/)"]+	pretty (HsStarRP r) = pretty r <> char '*'+	pretty (HsStarGRP r) = pretty r <> text "*!"+	pretty (HsPlusRP r) = pretty r <> char '+'+	pretty (HsPlusGRP r) = pretty r <> text "+!"+	pretty (HsOptRP r) = pretty r <> char '?'+	pretty (HsOptGRP r) = pretty r <> text "?!"+	pretty (HsEitherRP r1 r2) = parens . myFsep $ +		[pretty r1, char '|', pretty r2]+	-- special case that would otherwise be buggy+	pretty (HsCAsRP n (HsIrrPat e)) =+		myFsep [pretty n <> text "@:", char '~' <> pretty e]+	pretty (HsCAsRP n r) = hcat [pretty n, text "@:", pretty r]+	-- Hsx+	pretty (HsXTag _ n attrs mattr cs) =+		let ax = maybe [] (return . pretty) mattr+		 in hcat $ +		     (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [char '>']):+		 	map pretty cs ++ [myFsep $ [text "</" <> pretty n, char '>']]+	pretty (HsXETag _ n attrs mattr) =+		let ax = maybe [] (return . pretty) mattr+		 in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ax ++ [text "/>"]+	pretty (HsXPcdata s) = text s+	pretty (HsXExpTag e) = +		myFsep $ [text "<%", pretty e, text "%>"]++instance Pretty HsXAttr where+	pretty (HsXAttr n v) =+		myFsep [pretty n, char '=', pretty v]++instance Pretty HsXName where+	pretty (HsXName n) = text n+	pretty (HsXDomName d n) = text d <> char ':' <> text n++--ppLetExp :: [HsDecl] -> HsExp -> Doc+ppLetExp l b = myFsep [text "let" <+> ppBody letIndent (map pretty l),+			text "in", pretty b]++ppWith binds = nest 2 (text "with" $$$ ppBody withIndent (map pretty binds))+withIndent = whereIndent++--------------------- Template Haskell -------------------------+instance Pretty HsReify where+	pretty (HsReifyDecl name) = ppReify "reifyDecl" name+	pretty (HsReifyType name) = ppReify "reifyType" name+	pretty (HsReifyFixity name) = ppReify "reifyFixity" name++ppReify t n = myFsep [text t, pretty n]++instance Pretty HsBracket where+	pretty (HsExpBracket e) = ppBracket "[|" e+	pretty (HsPatBracket p) = ppBracket "[p|" p+	pretty (HsTypeBracket t) = ppBracket "[t|" t+	pretty (HsDeclBracket d) =+		myFsep $ text "[d|" : map pretty d ++ [text "|]"]++ppBracket o x = myFsep [text o, pretty x, text "|]"]++instance Pretty HsSplice where+	pretty (HsIdSplice s) = char '$' <> text s+	pretty (HsParenSplice e) =+		myFsep [text "$(", pretty e, char ')']++------------------------- Patterns -----------------------------++instance Pretty HsPat where+	prettyPrec _ (HsPVar name) = pretty name+	prettyPrec _ (HsPLit lit) = pretty lit+	prettyPrec _ (HsPNeg p) = myFsep [char '-', pretty p]+	prettyPrec p (HsPInfixApp a op b) = parensIf (p > 0) $+		myFsep [pretty a, pretty (HsQConOp op), pretty b]+	prettyPrec p (HsPApp n ps) = parensIf (p > 1) $+		myFsep (pretty n : map pretty ps)+	prettyPrec _ (HsPTuple ps) = parenList . map pretty $ ps+	prettyPrec _ (HsPList ps) =+		bracketList . punctuate comma . map pretty $ ps+	prettyPrec _ (HsPParen p) = parens . pretty $ p+	prettyPrec _ (HsPRec c fields) =+		pretty c <> (braceList . map pretty $ fields)+	-- special case that would otherwise be buggy+	prettyPrec _ (HsPAsPat name (HsPIrrPat pat)) =+		myFsep [pretty name <> char '@', char '~' <> pretty pat]+	prettyPrec _ (HsPAsPat name pat) =+		hcat [pretty name, char '@', pretty pat]+	prettyPrec _ HsPWildCard = char '_'+	prettyPrec _ (HsPIrrPat pat) = char '~' <> pretty pat+	prettyPrec _ (HsPRPat _ rs) = +		myFsep $ text "[/" : map pretty rs ++ [text "/]"]+	prettyPrec _ (HsPatTypeSig _pos pat ty) =+		myFsep [pretty pat, text "::", pretty ty]++	-- Hsx+	prettyPrec _ (HsPXTag _ n attrs mattr cp) =+		let ap = maybe [] (return . pretty) mattr+		 in hcat $ -- TODO: should not introduce blanks+		      (myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [char '>']):+			prettyChildren cp ++ [myFsep $ [text "</" <> pretty n, char '>']]+	prettyPrec _ (HsPXETag _ n attrs mattr) =+		let ap = maybe [] (return . pretty) mattr+		 in myFsep $ (char '<' <> pretty n): map pretty attrs ++ ap ++ [text "/>"]+	prettyPrec _ (HsPXPcdata s) = text s+	prettyPrec _ (HsPXPatTag p) = +		myFsep $ [text "<%", pretty p, text "%>"]++prettyChildren :: HsPat -> [Doc]+prettyChildren p = case p of+	HsPList ps  -> map prettyChild ps+	HsPRPat _ _ -> [pretty p]+	_ 	    -> error "The pattern representing the children of an xml pattern\+				\ should always be a list."++prettyChild :: HsPat -> Doc+prettyChild p = case p of+	HsPXTag _ _ _ _ _ -> pretty p+	HsPXETag _ _ _ _  -> pretty p+	HsPXPatTag _  	  -> pretty p+	HsPXPcdata _  	  -> pretty p+	_	      	  -> pretty $ HsPXPatTag p++instance Pretty HsPXAttr where+	pretty (HsPXAttr n p) = +		myFsep [pretty n, char '=', pretty p]++instance Pretty HsPatField where+	pretty (HsPFieldPat name pat) =+		myFsep [pretty name, equals, pretty pat]++--------------------- Regular Patterns -------------------------++instance Pretty HsRPat where+	pretty (HsRPStar r) = pretty r <> char '*'+	pretty (HsRPStarG r) = pretty r <> text "*!"+	pretty (HsRPPlus r) = pretty r <> char '+'+	pretty (HsRPPlusG r) = pretty r <> text "+!"+	pretty (HsRPOpt r) = pretty r <> char '?'+	pretty (HsRPOptG r) = pretty r <> text "?!"+	pretty (HsRPEither r1 r2) = parens . myFsep $ +		[pretty r1, char '|', pretty r2]+	pretty (HsRPSeq rs) =+		myFsep $ text "(/" : map pretty rs ++ [text "/)"]+	-- special case that would otherwise be buggy+	pretty (HsRPCAs n (HsRPPat (HsPIrrPat p))) =+		myFsep [pretty n <> text "@:", char '~' <> pretty p]+	pretty (HsRPCAs n r) = hcat [pretty n, text "@:", pretty r]+	-- special case that would otherwise be buggy+	pretty (HsRPAs n (HsRPPat (HsPIrrPat p))) =+		myFsep [pretty n <> text "@:", char '~' <> pretty p]+	pretty (HsRPAs n r) = hcat [pretty n, char '@', pretty r]+	pretty (HsRPPat p) = pretty p+	pretty (HsRPParen rp) = parens . pretty $ rp++------------------------- Case bodies  -------------------------+instance Pretty HsAlt where+	pretty (HsAlt _pos e gAlts binds) =+		pretty e <+> pretty gAlts $$$ ppWhere binds++instance Pretty HsGuardedAlts where+	pretty (HsUnGuardedAlt e) = text "->" <+> pretty e+	pretty (HsGuardedAlts altList) = myVcat . map pretty $ altList++instance Pretty HsGuardedAlt where+	pretty (HsGuardedAlt _pos guards body) =+		myFsep $ char '|': (punctuate comma . map pretty $ guards) ++ [text "->", pretty body]++------------------------- Statements in monads, guards & list comprehensions -----+instance Pretty HsStmt where+	pretty (HsGenerator _loc e from) =+		pretty e <+> text "<-" <+> pretty from+	pretty (HsQualifier e) = pretty e+	-- two cases for lets+	pretty (HsLetStmt (HsBDecls declList)) =+		ppLetStmt declList+	pretty (HsLetStmt (HsIPBinds bindList)) =+		ppLetStmt bindList++ppLetStmt l = text "let" $$$ ppBody letIndent (map pretty l)+	+------------------------- Record updates+instance Pretty HsFieldUpdate where+	pretty (HsFieldUpdate name e) =+		myFsep [pretty name, equals, pretty e]++------------------------- Names -------------------------+instance Pretty HsQOp where+	pretty (HsQVarOp n) = ppHsQNameInfix n+	pretty (HsQConOp n) = ppHsQNameInfix n++ppHsQNameInfix :: HsQName -> Doc+ppHsQNameInfix name+	| isSymbolName (getName name) = ppHsQName name+	| otherwise = char '`' <> ppHsQName name <> char '`'++instance Pretty HsQName where+	pretty name = case name of+		UnQual (HsSymbol ('#':_)) -> char '(' <+> ppHsQName name <+> char ')'+		_ -> parensIf (isSymbolName (getName name)) (ppHsQName name)++ppHsQName :: HsQName -> Doc+ppHsQName (UnQual name) = ppHsName name+ppHsQName (Qual m name) = pretty m <> char '.' <> ppHsName name+ppHsQName (Special sym) = text (specialName sym)++instance Pretty HsOp where+	pretty (HsVarOp n) = ppHsNameInfix n+	pretty (HsConOp n) = ppHsNameInfix n++ppHsNameInfix :: HsName -> Doc+ppHsNameInfix name+	| isSymbolName name = ppHsName name+	| otherwise = char '`' <> ppHsName name <> char '`'++instance Pretty HsName where+	pretty name = case name of+		HsSymbol ('#':_) -> char '(' <+> ppHsName name <+> char ')'+		_ -> parensIf (isSymbolName name) (ppHsName name)++ppHsName :: HsName -> Doc+ppHsName (HsIdent s) = text s+ppHsName (HsSymbol s) = text s++instance Pretty HsIPName where+	pretty (HsIPDup s) = char '?' <> text s+	pretty (HsIPLin s) = char '%' <> text s+	+instance Pretty HsIPBind where+	pretty (HsIPBind _loc ipname exp) =+		myFsep [pretty ipname, equals, pretty exp]++instance Pretty HsCName where+	pretty (HsVarName n) = pretty n+	pretty (HsConName n) = pretty n++isSymbolName :: HsName -> Bool+isSymbolName (HsSymbol _) = True+isSymbolName _ = False++getName :: HsQName -> HsName+getName (UnQual s) = s+getName (Qual _ s) = s+getName (Special HsCons) = HsSymbol ":"+getName (Special HsFunCon) = HsSymbol "->"+getName (Special s) = HsIdent (specialName s)++specialName :: HsSpecialCon -> String+specialName HsUnitCon = "()"+specialName HsListCon = "[]"+specialName HsFunCon = "->"+specialName (HsTupleCon n) = "(" ++ replicate (n-1) ',' ++ ")"+specialName HsCons = ":"++ppHsContext :: HsContext -> Doc+ppHsContext []      = empty+ppHsContext context = mySep [parenList (map pretty context), text "=>"]++-- hacked for multi-parameter type classes+instance Pretty HsAsst where+	pretty (HsClassA a ts) = myFsep $ ppHsQName a : map ppHsAType ts+	pretty (HsIParam i t)  = myFsep $ [pretty i, text "::", pretty t]++------------------------- pp utils -------------------------+maybePP :: (a -> Doc) -> Maybe a -> Doc+maybePP pp Nothing = empty+maybePP pp (Just a) = pp a++parenList :: [Doc] -> Doc+parenList = parens . myFsepSimple . punctuate comma++hashParenList :: [Doc] -> Doc+hashParenList = hashParens . myFsepSimple . punctuate comma +  where hashParens = parens . hashes+  	hashes = \doc -> char '#' <> doc <> char '#'++braceList :: [Doc] -> Doc+braceList = braces . myFsepSimple . punctuate comma++bracketList :: [Doc] -> Doc+bracketList = brackets . myFsepSimple++-- Wrap in braces and semicolons, with an extra space at the start in+-- case the first doc begins with "-", which would be scanned as {-+flatBlock :: [Doc] -> Doc+flatBlock = braces . (space <>) . hsep . punctuate semi++-- Same, but put each thing on a separate line+prettyBlock :: [Doc] -> Doc+prettyBlock = braces . (space <>) . vcat . punctuate semi++-- Monadic PP Combinators -- these examine the env++blankline :: Doc -> Doc+blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout+			      then space $$ dl else dl}+topLevel :: Doc -> [Doc] -> Doc+topLevel header dl = do+	 e <- fmap layout getPPEnv+	 case e of+	     PPOffsideRule -> header $$ vcat dl+	     PPSemiColon -> header $$ prettyBlock dl+	     PPInLine -> header $$ prettyBlock dl+	     PPNoLayout -> header <+> flatBlock dl++ppBody :: (PPHsMode -> Int) -> [Doc] -> Doc+ppBody f dl = do+	 e <- fmap layout getPPEnv+	 case e of PPOffsideRule -> indent+		   PPSemiColon   -> indentExplicit+		   _ -> flatBlock dl+		   where+		   indent  = do{i <-fmap f getPPEnv;nest i . vcat $ dl}+		   indentExplicit = do {i <- fmap f getPPEnv;+			   nest i . prettyBlock $ dl}++($$$) :: Doc -> Doc -> Doc+a $$$ b = layoutChoice (a $$) (a <+>) b++mySep :: [Doc] -> Doc+mySep = layoutChoice mySep' hsep+	where+	-- ensure paragraph fills with indentation.+	mySep' [x]    = x+	mySep' (x:xs) = x <+> fsep xs+	mySep' []     = error "Internal error: mySep"++myVcat :: [Doc] -> Doc+myVcat = layoutChoice vcat hsep++myFsepSimple :: [Doc] -> Doc+myFsepSimple = layoutChoice fsep hsep++-- same, except that continuation lines are indented,+-- which is necessary to avoid triggering the offside rule.+myFsep :: [Doc] -> Doc+myFsep = layoutChoice fsep' hsep+	where	fsep' [] = empty+		fsep' (d:ds) = do+			e <- getPPEnv+			let n = onsideIndent e+			nest n (fsep (nest (-n) d:ds))++layoutChoice :: (a -> Doc) -> (a -> Doc) -> a -> Doc+layoutChoice a b dl = do e <- getPPEnv+                         if layout e == PPOffsideRule ||+                            layout e == PPSemiColon+                          then a dl else b dl++-- Prefix something with a LINE pragma, if requested.+-- GHC's LINE pragma actually sets the current line number to n-1, so+-- that the following line is line n.  But if there's no newline before+-- the line we're talking about, we need to compensate by adding 1.++markLine :: SrcLoc -> Doc -> Doc+markLine loc doc = do+	e <- getPPEnv+	let y = srcLine loc+	let line l =+	      text ("{-# LINE " ++ show l ++ " \"" ++ srcFilename loc ++ "\" #-}")+	if linePragmas e then layoutChoice (line y $$) (line (y+1) <+>) doc+	      else doc
+ _darcs/pristine/Preprocessor/Hsx/Syntax.hs view
@@ -0,0 +1,806 @@+{-# OPTIONS_GHC -fglasgow-exts -cpp #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Hsx.Syntax+-- Original    :  Language.Haskell.Syntax+-- Copyright   :  (c) Niklas Broberg 2004,+--                (c) The GHC Team, 1997-2000+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- A suite of datatypes describing the abstract syntax of Haskell 98+-- <http://www.haskell.org/onlinereport/> plus some extensions:+--+--   * multi-parameter type classes with functional dependencies+--+--   * parameters of type class assertions are unrestricted+--+--   * 'forall' types as universal and existential quantification+--+--   * pattern guards+--+--   * implicit parameters+--+--   * generalised algebraic data types+--+--   * template haskell+--+--   * empty data type declarations+--+--   * unboxed tuples+--+--   * regular patterns (HaRP)+--+--   * HSP-style XML expressions and patterns (HSP)+--+-- Also worth noting is that (n+k) patterns from Haskell 98 are not supported+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Syntax (+    -- * Modules+    HsModule(..), HsPragma(..), HsExportSpec(..),+    HsImportDecl(..), HsImportSpec(..), HsAssoc(..),+    -- * Declarations+    HsDecl(..), HsBinds(..), HsIPBind(..), +    HsGadtDecl(..), HsConDecl(..), HsQualConDecl(..), HsBangType(..),+    HsMatch(..), HsRhs(..), HsGuardedRhs(..),+    -- * Class Assertions and Contexts+    HsContext, HsFunDep(..), HsAsst(..),+    -- * Types+    HsType(..), HsBoxed(..),+    -- * Expressions+    HsExp(..), HsStmt(..), HsFieldUpdate(..),+    HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..), +    -- * Patterns+    HsPat(..), HsPatField(..),+    -- * Literals+    HsLiteral(..),+    -- * Variables, Constructors and Operators+    Module(..), HsQName(..), HsName(..), HsQOp(..), HsOp(..),+    HsSpecialCon(..), HsCName(..), HsIPName(..),+    +    -- * Template Haskell+    HsReify(..), HsBracket(..), HsSplice(..),+    +    -- * HaRP+    HsRPat(..),+    +    -- * Hsx+    HsXAttr(..), HsXName(..), HsPXAttr(..),++    -- * FFI+    HsSafety(..), HsCallConv(..),++    -- * Builtin names++    -- ** Modules+    prelude_mod, main_mod,+    -- ** Main function of a program+    main_name,+    -- ** Constructors+    unit_con_name, tuple_con_name, list_cons_name,+    unit_con, tuple_con,+    -- ** Special identifiers+    as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name,+    export_name, safe_name, unsafe_name, threadsafe_name, stdcall_name, ccall_name,+    -- ** Type constructors+    unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name,+    unit_tycon, fun_tycon, list_tycon, tuple_tycon,++    -- * Source coordinates+    SrcLoc(..),+  ) where+++#ifdef __GLASGOW_HASKELL__+import Data.Generics.Basics+import Data.Generics.Instances+#endif++-- | A position in the source.+data SrcLoc = SrcLoc {+		srcFilename :: String,+		srcLine :: Int,+		srcColumn :: Int+		}+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif+  +-- | The name of a Haskell module.+newtype Module = Module String+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | Constructors with special syntax.+-- These names are never qualified, and always refer to builtin type or+-- data constructors.++data HsSpecialCon+	= HsUnitCon		-- ^ unit type and data constructor @()@+	| HsListCon		-- ^ list type constructor @[]@+	| HsFunCon		-- ^ function type constructor @->@+	| HsTupleCon Int	-- ^ /n/-ary tuple type and data+				--   constructors @(,)@ etc+	| HsCons		-- ^ list data constructor @(:)@+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | This type is used to represent qualified variables, and also+-- qualified constructors.+data HsQName+	= Qual Module HsName	-- ^ name qualified with a module name+	| UnQual HsName		-- ^ unqualified name+	| Special HsSpecialCon	-- ^ built-in constructor with special syntax+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | This type is used to represent variables, and also constructors.+data HsName+	= HsIdent String	-- ^ /varid/ or /conid/.+	| HsSymbol String	-- ^ /varsym/ or /consym/+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | This type is used to represent implicit parameter names.+data HsIPName+	= HsIPDup String -- ?x+	| HsIPLin String -- %x+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | Possibly qualified infix operators (/qop/), appearing in expressions.+data HsQOp+	= HsQVarOp HsQName	-- ^ variable operator (/qvarop/)+	| HsQConOp HsQName	-- ^ constructor operator (/qconop/)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | Operators, appearing in @infix@ declarations.+data HsOp+	= HsVarOp HsName	-- ^ variable operator (/varop/)+	| HsConOp HsName	-- ^ constructor operator (/conop/)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | A name (/cname/) of a component of a class or data type in an @import@+-- or export specification.+data HsCName+	= HsVarName HsName	-- ^ name of a method or field+	| HsConName HsName	-- ^ name of a data constructor+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Ord,Show,Typeable,Data)+#else+  deriving (Eq,Ord,Show)+#endif++-- | A Haskell source module.+data HsModule = HsModule SrcLoc [HsPragma] Module (Maybe [HsExportSpec])+                         [HsImportDecl] [HsDecl]+#ifdef __GLASGOW_HASKELL__+  deriving (Show,Typeable,Data)+#else+  deriving (Show)+#endif++-- | A pragma at the beginning of a module.+data HsPragma = HsPragma String+#ifdef __GLASGOW_HASKELL__+  deriving (Show,Typeable,Data)+#else+  deriving (Show)+#endif++-- | Export specification.+data HsExportSpec+	 = HsEVar HsQName			-- ^ variable+	 | HsEAbs HsQName			-- ^ @T@:+			-- a class or datatype exported abstractly,+			-- or a type synonym.+	 | HsEThingAll HsQName			-- ^ @T(..)@:+			-- a class exported with all of its methods, or+			-- a datatype exported with all of its constructors.+	 | HsEThingWith HsQName [HsCName]	-- ^ @T(C_1,...,C_n)@:+			-- a class exported with some of its methods, or+			-- a datatype exported with some of its constructors.+	 | HsEModuleContents Module		-- ^ @module M@:+			-- re-export a module.+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Import declaration.+data HsImportDecl = HsImportDecl+	{ importLoc :: SrcLoc		-- ^ position of the @import@ keyword.+	, importModule :: Module	-- ^ name of the module imported.+	, importQualified :: Bool	-- ^ imported @qualified@?+	, importAs :: Maybe Module	-- ^ optional alias name in an+					-- @as@ clause.+	, importSpecs :: Maybe (Bool,[HsImportSpec])+			-- ^ optional list of import specifications.+			-- The 'Bool' is 'True' if the names are excluded+			-- by @hiding@.+	}+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Import specification.+data HsImportSpec+	 = HsIVar HsName			-- ^ variable+	 | HsIAbs HsName			-- ^ @T@:+			-- the name of a class, datatype or type synonym.+	 | HsIThingAll HsName			-- ^ @T(..)@:+			-- a class imported with all of its methods, or+			-- a datatype imported with all of its constructors.+	 | HsIThingWith HsName [HsCName]	-- ^ @T(C_1,...,C_n)@:+			-- a class imported with some of its methods, or+			-- a datatype imported with some of its constructors.+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Associativity of an operator.+data HsAssoc+	 = HsAssocNone	-- ^ non-associative operator (declared with @infix@)+	 | HsAssocLeft	-- ^ left-associative operator (declared with @infixl@).+	 | HsAssocRight	-- ^ right-associative operator (declared with @infixr@)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsDecl+	 = HsTypeDecl	 SrcLoc HsName [HsName] HsType+	 | HsDataDecl	 SrcLoc HsContext HsName [HsName] [HsQualConDecl] [HsQName]+	 | HsGDataDecl 	 SrcLoc HsContext HsName [HsName] [HsGadtDecl] {-no deriving-}+	 | HsInfixDecl   SrcLoc HsAssoc Int [HsOp]+	 | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsQualConDecl [HsQName]+	 | HsClassDecl	 SrcLoc HsContext HsName [HsName] [HsFunDep] [HsDecl]+	 | HsInstDecl	 SrcLoc HsContext HsQName [HsType] [HsDecl]+	 | HsDefaultDecl SrcLoc [HsType]+         | HsSpliceDecl  SrcLoc HsSplice+	 | HsTypeSig	 SrcLoc [HsName] HsType+	 | HsFunBind     [HsMatch]+	 | HsPatBind	 SrcLoc HsPat HsRhs {-where-} HsBinds+	 | HsForImp	 SrcLoc HsCallConv HsSafety String HsName HsType+	 | HsForExp	 SrcLoc HsCallConv          String HsName HsType+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsBinds+	= HsBDecls [HsDecl]+	| HsIPBinds [HsIPBind]+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsIPBind = HsIPBind SrcLoc HsIPName HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Clauses of a function binding.+data HsMatch+	 = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} HsBinds+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsQualConDecl+	= HsQualConDecl SrcLoc +	    {-forall-} [HsName] {- . -} HsContext+		{- => -} HsConDecl+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsGadtDecl +	= HsGadtDecl SrcLoc HsName HsType+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Declaration of a data constructor.+data HsConDecl+	 = HsConDecl HsName [HsBangType]+				-- ^ ordinary data constructor+	 | HsRecDecl HsName [([HsName],HsBangType)]+				-- ^ record constructor+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | The type of a constructor argument or field, optionally including+-- a strictness annotation.+data HsBangType+	 = HsBangedTy   HsType	-- ^ strict component, marked with \"@!@\"+	 | HsUnBangedTy HsType	-- ^ non-strict component+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | The right hand side of a function or pattern binding.+data HsRhs+	 = HsUnGuardedRhs HsExp	-- ^ unguarded right hand side (/exp/)+	 | HsGuardedRhss  [HsGuardedRhs]+				-- ^ guarded right hand side (/gdrhs/)+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+-- | A guarded right hand side @|@ /exp/ @=@ /exp/.+-- The first expression will be Boolean-valued.+data HsGuardedRhs+	 = HsGuardedRhs SrcLoc [HsStmt] HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | A type qualified with a context.+--   An unqualified type has an empty context.++data HsType+	 = HsTyForall +	 	(Maybe [HsName])+	 	HsContext+	 	HsType+	 | HsTyFun   HsType HsType	-- ^ function type+	 | HsTyTuple HsBoxed [HsType]	-- ^ tuple type, possibly boxed+	 | HsTyApp   HsType HsType	-- ^ application of a type constructor+	 | HsTyVar   HsName		-- ^ type variable+	 | HsTyCon   HsQName		-- ^ named type or type constructor+	 | HsTyPred  HsAsst 		-- ^ assertion of an implicit parameter+	 | HsTyInfix HsType HsQName HsType -- ^ infix type constructor+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsBoxed = Boxed | Unboxed+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+++-- | A functional dependency, given on the form+--   l1 l2 ... ln -> r2 r3 .. rn+data HsFunDep+	= HsFunDep [HsName] [HsName]+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+++type HsContext = [HsAsst]++-- | Class assertions.+--   In Haskell 98, the argument would be a /tyvar/, but this definition+--   allows multiple parameters, and allows them to be /type/s.+--   Also extended with support for implicit parameters.+data HsAsst    	= HsClassA HsQName [HsType]+		| HsIParam HsIPName HsType+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | /literal/+-- Values of this type hold the abstract value of the literal, not the+-- precise string representation used.  For example, @10@, @0o12@ and @0xa@+-- have the same representation.+data HsLiteral+	= HsChar	Char		-- ^ character literal+	| HsString	String		-- ^ string literal+	| HsInt		Integer		-- ^ integer literal+	| HsFrac	Rational	-- ^ floating point literal+	| HsCharPrim	Char		-- ^ GHC unboxed character literal+	| HsStringPrim	String		-- ^ GHC unboxed string literal+	| HsIntPrim	Integer		-- ^ GHC unboxed integer literal+	| HsFloatPrim	Rational	-- ^ GHC unboxed float literal+	| HsDoublePrim	Rational	-- ^ GHC unboxed double literal+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | Haskell expressions.+--+-- /Notes:/+--+-- * Because it is difficult for parsers to distinguish patterns from+--   expressions, they typically parse them in the same way and then check+--   that they have the appropriate form.  Hence the expression type+--   includes some forms that are found only in patterns.  After these+--   checks, these constructors should not be used.+--+-- * The parser does not take precedence and associativity into account,+--   so it will leave 'HsInfixApp's associated to the left.+--+-- * The 'Preprocessor.Pretty.Pretty' instance for 'HsExp' does not+--   add parentheses in printing.++data HsExp+	= HsVar HsQName			-- ^ variable+	| HsIPVar HsIPName		-- ^ implicit parameter variable+	| HsCon HsQName			-- ^ data constructor+	| HsLit HsLiteral		-- ^ literal constant+	| HsInfixApp HsExp HsQOp HsExp	-- ^ infix application+	| HsApp HsExp HsExp		-- ^ ordinary application+	| HsNegApp HsExp		-- ^ negation expression @-@ /exp/+	| HsLambda SrcLoc [HsPat] HsExp -- ^ lambda expression+	| HsLet HsBinds HsExp		-- ^ local declarations with @let@+	| HsDLet [HsIPBind] HsExp	-- ^ local declarations of implicit parameters (hugs)+	| HsWith HsExp [HsIPBind]	-- ^ local declarations of implicit parameters+	| HsIf HsExp HsExp HsExp	-- ^ @if@ /exp/ @then@ /exp/ @else@ /exp/+	| HsCase HsExp [HsAlt]		-- ^ @case@ /exp/ @of@ /alts/+	| HsDo [HsStmt]			-- ^ @do@-expression:+					-- the last statement in the list+					-- should be an expression.+	| HsMDo [HsStmt]		-- ^ @mdo@-expression+	| HsTuple [HsExp]		-- ^ tuple expression+	| HsList [HsExp]		-- ^ list expression+	| HsParen HsExp			-- ^ parenthesized expression+	| HsLeftSection HsExp HsQOp	-- ^ left section @(@/exp/ /qop/@)@+	| HsRightSection HsQOp HsExp	-- ^ right section @(@/qop/ /exp/@)@+	| HsRecConstr HsQName [HsFieldUpdate]+					-- ^ record construction expression+	| HsRecUpdate HsExp [HsFieldUpdate]+					-- ^ record update expression+	| HsEnumFrom HsExp		-- ^ unbounded arithmetic sequence,+					-- incrementing by 1+	| HsEnumFromTo HsExp HsExp	-- ^ bounded arithmetic sequence,+					-- incrementing by 1+	| HsEnumFromThen HsExp HsExp	-- ^ unbounded arithmetic sequence,+					-- with first two elements given+	| HsEnumFromThenTo HsExp HsExp HsExp+					-- ^ bounded arithmetic sequence,+					-- with first two elements given+	| HsListComp HsExp [HsStmt]	-- ^ list comprehension+	| HsExpTypeSig SrcLoc HsExp HsType+					-- ^ expression type signature+	| HsAsPat HsName HsExp		-- ^ patterns only+	| HsWildCard			-- ^ patterns only+	| HsIrrPat HsExp		-- ^ patterns only++-- HaRP+	| HsRPats SrcLoc [HsExp]	-- ^ regular patterns only+	| HsSeqRP [HsExp]		-- ^ regular patterns only+	| HsStarRP HsExp		-- ^ regular patterns only+	| HsStarGRP HsExp		-- ^ regular patterns only+	| HsPlusRP HsExp		-- ^ regular patterns only+	| HsPlusGRP HsExp		-- ^ regular patterns only+	| HsOptRP HsExp			-- ^ regular patterns only+	| HsOptGRP HsExp		-- ^ regular patterns only+	| HsEitherRP HsExp HsExp	-- ^ regular patterns only+	| HsCAsRP HsName HsExp		-- ^ regular patterns only+	+-- Template Haskell+	| HsReifyExp HsReify+	| HsBracketExp HsBracket+	| HsSpliceExp HsSplice+	+-- Hsx+	| HsXTag SrcLoc HsXName [HsXAttr] (Maybe HsExp) [HsExp]+	| HsXETag SrcLoc HsXName [HsXAttr] (Maybe HsExp)+	| HsXPcdata String+	| HsXExpTag HsExp++-- Functor sugar+        | HsFunctorUnit HsExp+        | HsFunctorCall HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsXName +	= HsXName String		-- <name ...+	| HsXDomName String String	-- <dom:name ...+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsXAttr = HsXAttr HsXName HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsReify +	= HsReifyType HsQName+	| HsReifyDecl HsQName+	| HsReifyFixity HsQName+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+ +data HsBracket+	= HsExpBracket HsExp+	| HsPatBracket HsPat+	| HsTypeBracket HsType+	| HsDeclBracket [HsDecl]+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsSplice+	= HsIdSplice String+	| HsParenSplice HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif+++-- FFI stuff+data HsSafety+	= PlayRisky+	| PlaySafe Bool+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsCallConv+	= StdCall+	| CCall+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++++-- | A pattern, to be matched against a value.+data HsPat+	= HsPVar HsName			-- ^ variable+	| HsPLit HsLiteral		-- ^ literal constant+	| HsPNeg HsPat			-- ^ negated pattern+	| HsPInfixApp HsPat HsQName HsPat+					-- ^ pattern with infix data constructor+	| HsPApp HsQName [HsPat]	-- ^ data constructor and argument+					-- patterns+	| HsPTuple [HsPat]		-- ^ tuple pattern+	| HsPList [HsPat]		-- ^ list pattern+	| HsPParen HsPat		-- ^ parenthesized pattern+	| HsPRec HsQName [HsPatField]	-- ^ labelled pattern+	| HsPAsPat HsName HsPat		-- ^ @\@@-pattern+	| HsPWildCard			-- ^ wildcard pattern (@_@)+	| HsPIrrPat HsPat		-- ^ irrefutable pattern (@~@)+	| HsPatTypeSig SrcLoc HsPat HsType+					-- ^ pattern type signature+	+-- HaRP+	| HsPRPat SrcLoc [HsRPat]	-- ^ regular pattern (HaRP)+-- Hsx+	| HsPXTag SrcLoc HsXName [HsPXAttr] (Maybe HsPat) HsPat+					-- ^ XML tag pattern+	| HsPXETag SrcLoc HsXName [HsPXAttr] (Maybe HsPat)+					-- ^ XML singleton tag pattern+	| HsPXPcdata String+					-- ^ XML PCDATA pattern+	| HsPXPatTag HsPat+					-- ^ XML embedded pattern+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An XML attribute in an XML tag pattern	+data HsPXAttr = HsPXAttr HsXName HsPat+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An entity in a regular pattern (HaRP)+data HsRPat+	= HsRPStar HsRPat+	| HsRPStarG HsRPat+	| HsRPPlus HsRPat+	| HsRPPlusG HsRPat+	| HsRPOpt HsRPat+	| HsRPOptG HsRPat+	| HsRPEither HsRPat HsRPat+	| HsRPSeq [HsRPat]+	| HsRPCAs HsName HsRPat+	| HsRPAs HsName HsRPat+	| HsRPParen HsRPat+	| HsRPPat HsPat+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An /fpat/ in a labeled record pattern.+data HsPatField+	= HsPFieldPat HsQName HsPat+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | This type represents both /stmt/ in a @do@-expression,+--   and /qual/ in a list comprehension, as well as /stmt/+--   in a pattern guard.+data HsStmt+	= HsGenerator SrcLoc HsPat HsExp+				-- ^ a generator /pat/ @<-@ /exp/+	| HsQualifier HsExp	-- ^ an /exp/ by itself: in a @do@-expression,+				-- an action whose result is discarded;+				-- in a list comprehension, a guard expression+	| HsLetStmt HsBinds	-- ^ local bindings+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An /fbind/ in a labeled construction or update.+data HsFieldUpdate+	= HsFieldUpdate HsQName HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | An /alt/ in a @case@ expression.+data HsAlt+	= HsAlt SrcLoc HsPat HsGuardedAlts HsBinds+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++data HsGuardedAlts+	= HsUnGuardedAlt HsExp		-- ^ @->@ /exp/+	| HsGuardedAlts  [HsGuardedAlt]	-- ^ /gdpat/+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-- | A guarded alternative @|@ /stmt/, ... , /stmt/ @->@ /exp/.+data HsGuardedAlt+	= HsGuardedAlt SrcLoc [HsStmt] HsExp+#ifdef __GLASGOW_HASKELL__+  deriving (Eq,Show,Typeable,Data)+#else+  deriving (Eq,Show)+#endif++-----------------------------------------------------------------------------+-- Builtin names.++prelude_mod, main_mod :: Module+prelude_mod	      = Module "Prelude"+main_mod	      = Module "Main"++main_name :: HsName+main_name	      = HsIdent "main"++unit_con_name :: HsQName+unit_con_name	      = Special HsUnitCon++tuple_con_name :: Int -> HsQName+tuple_con_name i      = Special (HsTupleCon (i+1))++list_cons_name :: HsQName+list_cons_name	      = Special HsCons++unit_con :: HsExp+unit_con	      = HsCon unit_con_name++tuple_con :: Int -> HsExp+tuple_con i	      = HsCon (tuple_con_name i)++as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name :: HsName+as_name	              = HsIdent "as"+qualified_name        = HsIdent "qualified"+hiding_name	      = HsIdent "hiding"+minus_name	      = HsSymbol "-"+pling_name	      = HsSymbol "!"+dot_name	      = HsSymbol "."++export_name, safe_name, unsafe_name, threadsafe_name, stdcall_name, ccall_name :: HsName+export_name		= HsIdent "export"+safe_name		= HsIdent "safe"+unsafe_name		= HsIdent "unsafe"+threadsafe_name		= HsIdent "threadsafe"+stdcall_name		= HsIdent "stdcall"+ccall_name		= HsIdent "ccall"++unit_tycon_name, fun_tycon_name, list_tycon_name :: HsQName+unit_tycon_name       = unit_con_name+fun_tycon_name        = Special HsFunCon+list_tycon_name       = Special HsListCon++tuple_tycon_name :: Int -> HsQName+tuple_tycon_name i    = tuple_con_name i++unit_tycon, fun_tycon, list_tycon :: HsType+unit_tycon	      = HsTyCon unit_tycon_name+fun_tycon	      = HsTyCon fun_tycon_name+list_tycon	      = HsTyCon list_tycon_name++tuple_tycon :: Int -> HsType+tuple_tycon i	      = HsTyCon (tuple_tycon_name i)
+ _darcs/pristine/Preprocessor/Hsx/Transform.hs view
@@ -0,0 +1,1797 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Preprocessor.Harp.Tranform+-- Copyright   :  (c) Niklas Broberg 2004,+-- License     :  BSD-style (see the file LICENSE.txt)+-- +-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se+-- Stability   :  experimental+-- Portability :  portable+--+-- Functions for transforming abstract Haskell code extended with regular +-- patterns into semantically equivalent normal abstract Haskell code. In+-- other words, we transform away regular patterns.+-----------------------------------------------------------------------------++module Preprocessor.Hsx.Transform (+	transform		-- :: HsModule -> HsModule+	) where++import Preprocessor.Hsx.Syntax+import Preprocessor.Hsx.Build+import Data.List (union)++import Debug.Trace (trace)++-----------------------------------------------------------------------------+-- A monad for threading a boolean value through the boilerplate code,+-- to signal whether a transformation has taken place or not.++newtype HsxM a = MkHsxM (HsxState -> (a, HsxState))++instance Monad HsxM where+ return x = MkHsxM (\s -> (x,s))+ (MkHsxM f) >>= k = MkHsxM (\s -> let (a, s') = f s+				      (MkHsxM f') = k a+				   in f' s')++getHsxState :: HsxM HsxState+getHsxState = MkHsxM (\s -> (s, s))++setHsxState :: HsxState -> HsxM ()+setHsxState s = MkHsxM (\_ -> ((),s))++instance Functor HsxM where+ fmap f hma = do a <- hma+		 return $ f a++-----++type HsxState = (Bool, Bool)++initHsxState :: HsxState+initHsxState = (False, False)++setHarpTransformed :: HsxM ()+setHarpTransformed = +	do (_,x) <- getHsxState+	   setHsxState (True,x)++setXmlTransformed :: HsxM ()+setXmlTransformed =+	do (h,_) <- getHsxState+	   setHsxState (h,True)++runHsxM :: HsxM a -> (a, (Bool, Bool))+runHsxM (MkHsxM f) = f initHsxState++-----------------------------------------------------------------------------+-- Traversing and transforming the syntax tree+++-- | Transform away occurences of regular patterns from an abstract+-- Haskell module, preserving semantics.+transform :: HsModule -> HsModule+transform (HsModule s prags m mes is decls) =+	let (decls', (harp, hsx)) = runHsxM $ mapM transformDecl decls+	    -- We may need to add an import for Match.hs that defines the matcher monad+	    imps1 = if harp +		     then (:) $ HsImportDecl s match_mod True+			  	 (Just match_qual_mod)+			  	 Nothing+		     else id+	    imps2 = {- if hsx+	    	     then (:) $ HsImportDecl s hsx_data_mod False+	    	     		 Nothing+	    	     		 Nothing+	    	     else -} id		-- we no longer want to import HSP.Data+            imps3 = if True --functor+                     then (:) $ HsImportDecl s functor_qual_mod True+                                 Nothing+                                 Nothing+                     else id+            prags' = HsPragma " OPTIONS_GHC -fth " : prags+	 in HsModule s prags' m mes (imps1 $ imps2 $ imps3 is) decls'++-----------------------------------------------------------------------------+-- Declarations++-- | Transform a declaration by transforming subterms that could+-- contain regular patterns.+transformDecl :: HsDecl -> HsxM HsDecl+transformDecl d = case d of+	-- Pattern binds can contain regular patterns in the pattern being bound+	-- as well as on the right-hand side and in declarations in a where clause+	HsPatBind srcloc pat rhs decls -> do+	  	-- Preserve semantics of irrefutable regular patterns by postponing+	  	-- their evaluation to a let-expression on the right-hand side+	  	let ([pat'], rnpss) = unzip $ renameIrrPats [pat]+	  	-- Transform the pattern itself+		([pat''], attrGuards, guards, decls'') <- transformPatterns [pat']+		-- Transform the right-hand side, and add any generated guards+		-- and let expressions to it+		rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs +		-- Transform declarations in the where clause, adding any generated+		-- declarations to it+		decls' <- case decls of+			   HsBDecls ds -> do ds' <- transformLetDecls ds+					     return $ HsBDecls $ decls'' ++ ds'+			   _           -> error "Cannot bind implicit parameters in the \+					    \ \'where\' clause of a function using regular patterns."+		return $ HsPatBind srcloc pat'' rhs' decls'++	-- Function binds can contain regular patterns in their matches+	HsFunBind ms -> fmap HsFunBind $ mapM transformMatch ms+	-- Instance declarations can contain regular patterns in the+	-- declarations of functions inside it+	HsInstDecl s c n ts decls ->+		fmap (HsInstDecl s c n ts) $ mapM transformDecl decls+	-- Class declarations can contain regular patterns in the+	-- declarations of automatically instantiated functions+	HsClassDecl s c n ns ds decls ->+		fmap (HsClassDecl s c n ns ds) $ mapM transformDecl decls+	-- Type signatures, type, newtype or data declarations, infix declarations+	-- and default declarations; none can contain regular patterns+	_ -> return d+	++-- | Transform a function "match" by generating pattern guards and+-- declarations representing regular patterns in the argument list.+-- Subterms, such as guards and the right-hand side, are also traversed+-- transformed.+transformMatch :: HsMatch -> HsxM HsMatch+transformMatch (HsMatch srcloc name pats rhs decls) = do+	-- Preserve semantics of irrefutable regular patterns by postponing+	-- their evaluation to a let-expression on the right-hand side+  	let (pats', rnpss) = unzip $ renameIrrPats pats+  	-- Transform the patterns that stand as arguments to the function+  	(pats'', attrGuards, guards, decls'') <- transformPatterns pats'+	-- Transform the right-hand side, and add any generated guards+	-- and let expressions to it+  	rhs' <- mkRhs srcloc (attrGuards ++ guards) (concat rnpss) rhs+	-- Transform declarations in the where clause, adding any generated+	-- declarations to it+  	decls' <- case decls of+  		   HsBDecls ds -> do ds' <- transformLetDecls ds+			  	     return $ HsBDecls $ decls'' ++ ds'+  		   _           -> error "Cannot bind implicit parameters in the \+  		  		     \ \'where\' clause of a function using regular patterns."++	return $ HsMatch srcloc name pats'' rhs' decls'+-- | Transform and update guards and right-hand side of a function or+-- pattern binding. The supplied list of guards is prepended to the +-- original guards, and subterms are traversed and transformed.+mkRhs :: SrcLoc -> [Guard] -> [(HsName, HsPat)] -> HsRhs -> HsxM HsRhs+mkRhs srcloc guards rnps (HsUnGuardedRhs rhs) = do+	-- Add the postponed patterns to the right-hand side by placing+	-- them in a let-expression to make them lazily evaluated.+	-- Then transform the whole right-hand side as an expression.+	rhs' <- transformExp $ addLetDecls srcloc rnps rhs+	case guards of +	 -- There were no guards before, and none should be added,+	 -- so we still have an unguarded right-hand side+	 [] -> return $ HsUnGuardedRhs rhs'+	 -- There are guards to add. These should be added as pattern+	 -- guards, i.e. as statements.+	 _  -> return $ HsGuardedRhss [HsGuardedRhs srcloc (map mkStmtGuard guards) rhs']+mkRhs _ guards rnps (HsGuardedRhss gdrhss) = fmap HsGuardedRhss $ mapM (mkGRhs guards rnps) gdrhss+  where mkGRhs :: [Guard] -> [(HsName, HsPat)] -> HsGuardedRhs -> HsxM HsGuardedRhs+	mkGRhs gs rnps (HsGuardedRhs s oldgs rhs) = do+		-- Add the postponed patterns to the right-hand side by placing+		-- them in a let-expression to make them lazily evaluated.+		-- Then transform the whole right-hand side as an expression.+		rhs' <- transformExp $ addLetDecls s rnps rhs+		-- Now there are guards, so first we need to transform those+		oldgs' <- fmap concat $ mapM (transformStmt Guard) oldgs+		-- ... and then prepend the newly generated ones, as statements+		return $ HsGuardedRhs s ((map mkStmtGuard gs) ++ oldgs') rhs'++-- | Place declarations of postponed regular patterns in a let-expression to+-- make them lazy, in order to make them behave as irrefutable patterns.+addLetDecls :: SrcLoc -> [(HsName, HsPat)] -> HsExp -> HsExp+addLetDecls s []   e = e 	-- no declarations to add+addLetDecls s rnps e = +	-- Place all postponed patterns in the same let-expression+	letE (map (mkDecl s) rnps) e++-- | Make pattern binds from postponed regular patterns+mkDecl :: SrcLoc -> (HsName, HsPat) -> HsDecl+mkDecl srcloc (n,p) = patBind srcloc p (var n)++------------------------------------------------------------------------------------+-- Expressions+	  		   	 +-- | Transform expressions by traversing subterms.+-- Of special interest are expressions that contain patterns as subterms,+-- i.e. @let@, @case@ and lambda expressions, and also list comprehensions+-- and @do@-expressions. All other expressions simply transform their+-- sub-expressions, if any.+-- Of special interest are of course also any xml expressions.+transformExp :: HsExp -> HsxM HsExp+transformExp e = case e of+	-- A standard xml tag should be transformed into an element of the+	-- XML datatype. Attributes should be made into a set of mappings, +	-- and children should be transformed.+	HsXTag _ name attrs mattr cs -> do+		-- Hey Pluto, look, we have XML in our syntax tree!+		setXmlTransformed+		let -- ... make tuples of the attributes+		    as = map mkAttr attrs+		-- ... transform the children+		cs' <- mapM transformChild cs+		-- ... and lift the values into the XML datatype.+		return $ paren $ metaMkTag name as mattr cs'++	  where	-- | Transform expressions appearing in child position of an xml tag.+		-- Expressions are first transformed, then wrapped in a call to+		-- @toXml@.+		transformChild :: HsExp -> HsxM HsExp+		transformChild e = do+			-- Transform the expression+			te <- transformExp e+			-- ... and apply the overloaded toXMLs to it+			return $ metaToXmls te+		    +	-- An empty xml tag should be transformed just as a standard tag,+	-- only that there are no children,+	HsXETag _ name attrs mattr -> do+		-- ... 'tis the season to be jolly, falalalalaaaa....+		setXmlTransformed+		let -- ... make tuples of the attributes   +		    as = map mkAttr attrs+		    -- ... and lift the values into the XML datatype.+		return $ paren $ metaMkETag name as mattr+	-- PCDATA should be lifted as a string into the XML datatype.+	HsXPcdata pcdata	-> do setXmlTransformed+				      return $ metaMkPcdata pcdata+	-- Escaped expressions should be treated as just expressions.+	HsXExpTag e		-> do setXmlTransformed+				      transformExp e+	+	-- Patterns as arguments to a lambda expression could be regular,+	-- but we cannot put the evaluation here since a lambda expression+	-- can have neither guards nor a where clause. Thus we must postpone +	-- them to a case expressions on the right-hand side.+	HsLambda s pats rhs -> do+		let -- First rename regular patterns+		    (ps, rnpss)  = unzip $ renameRPats pats+		    -- ... group them up to one big tuple+		    (rns, rps) = unzip (concat rnpss)+		    alt1 = alt s (pTuple rps) rhs+		    texp = varTuple rns+		    -- ... and put it all in a case expression, which+		    -- can then be transformed in the normal way.+                    e = if null rns then rhs else caseE texp [alt1]+		rhs' <- transformExp e+		return $ HsLambda s ps rhs'+	-- A let expression can contain regular patterns in the declarations, +	-- or in the expression that makes up the body of the let.+	HsLet (HsBDecls ds) e -> do+		-- Declarations appearing in a let expression must be transformed+		-- in a special way due to scoping, see later documentation.+		-- The body is transformed as a normal expression.+		ds' <- transformLetDecls ds+		e'  <- transformExp e+		return $ letE ds' e'+	-- Bindings of implicit parameters can appear either in ordinary let+	-- expressions (GHC), in dlet expressions (Hugs) or in a with clause+	-- (both). Such bindings are transformed in a special way. The body +	-- is transformed as a normal expression in all cases.+	HsLet (HsIPBinds is) e -> do+		is' <- mapM transformIPBind is+		e'  <- transformExp e+		return $ HsLet (HsIPBinds is') e'+	HsDLet ipbs e -> do+		ipbs' <- mapM transformIPBind ipbs+		e'    <- transformExp e+		return $ HsDLet ipbs' e'+	HsWith e ipbs -> do+		ipbs' <- mapM transformIPBind ipbs+		e'    <- transformExp e+		return $ HsWith e' ipbs'+	-- A case expression can contain regular patterns in the expression+	-- that is the subject of the casing, or in either of the alternatives.+	HsCase e alts -> do+		e'    <- transformExp e+		alts' <- mapM transformAlt alts+		return $ HsCase e' alts'+	-- A do expression can contain regular patterns in its statements.+	HsDo stmts -> do+		stmts' <- fmap concat $ mapM (transformStmt Do) stmts+		return $ HsDo stmts'+	HsMDo stmts -> do+		stmts' <- fmap concat $ mapM (transformStmt Do) stmts+		return $ HsMDo stmts'+	-- A list comprehension can contain regular patterns in the result +	-- expression, or in any of its statements.+	HsListComp e stmts	-> do+		e'     <- transformExp e+		stmts' <- fmap concat $ mapM (transformStmt ListComp) stmts+		return $ HsListComp e' stmts'+	-- All other expressions simply transform their immediate subterms.+	HsInfixApp e1 op e2	-> transform2exp e1 e2 +					(\e1 e2 -> HsInfixApp e1 op e2)+	HsApp e1 e2         	-> transform2exp e1 e2 HsApp+	HsNegApp e 	    	-> fmap HsNegApp $ transformExp e+	HsIf e1 e2 e3 	    	-> transform3exp e1 e2 e3 HsIf+	HsTuple es	    	-> fmap HsTuple $ mapM transformExp es+	HsList es	    	-> fmap HsList $ mapM transformExp es+	HsParen e	    	-> fmap HsParen $ transformExp e+	HsLeftSection e op  	-> do e' <- transformExp e+				      return $ HsLeftSection e' op+	HsRightSection op e 	-> fmap (HsRightSection op) $ transformExp e+	HsRecConstr n fus   	-> fmap (HsRecConstr n) $ mapM transformFieldUpdate fus+	HsRecUpdate e fus   	-> do e'   <- transformExp e+				      fus' <- mapM transformFieldUpdate fus+				      return $ HsRecUpdate e' fus'+	HsEnumFrom e	    	-> fmap HsEnumFrom $ transformExp e+	HsEnumFromTo e1 e2  	-> transform2exp e1 e2 HsEnumFromTo+	HsEnumFromThen e1 e2 	-> transform2exp e1 e2 HsEnumFromThen+	HsEnumFromThenTo e1 e2 e3 -> transform3exp e1 e2 e3 HsEnumFromThenTo+	HsExpTypeSig s e t	-> do e' <- transformExp e+				      return $ HsExpTypeSig s e' t+	HsFunctorUnit e		-> do e' <- transformExp e+                                      return $ HsSpliceExp $ HsParenSplice $ +                                          app sugarFun $ HsBracketExp $+                                              HsExpBracket e'+        HsFunctorCall e         -> do e' <- transformExp e+                                      return $ paren $ app callFun e'+	_			-> return e	-- Warning! Does not work with TH bracketed expressions ([| ... |])++  where transformFieldUpdate :: HsFieldUpdate -> HsxM HsFieldUpdate+	transformFieldUpdate (HsFieldUpdate n e) =+		fmap (HsFieldUpdate n) $ transformExp e+		+	transform2exp :: HsExp -> HsExp -> (HsExp -> HsExp -> HsExp) -> HsxM HsExp+	transform2exp e1 e2 f = do e1' <- transformExp e1+				   e2' <- transformExp e2+				   return $ f e1' e2'+	+	transform3exp :: HsExp -> HsExp -> HsExp -> (HsExp -> HsExp -> HsExp -> HsExp) -> HsxM HsExp+	transform3exp e1 e2 e3 f = do e1' <- transformExp e1+				      e2' <- transformExp e2+				      e3' <- transformExp e3+				      return $ f e1' e2' e3'++	mkAttr :: HsXAttr -> HsExp+	mkAttr (HsXAttr name e) = +		paren (metaMkName name `metaAssign` e)+++-- | Transform pattern bind declarations inside a @let@-expression by transforming +-- subterms that could appear as regular patterns, as well as transforming the bound+-- pattern itself. The reason we need to do this in a special way is scoping, i.e.+-- in the expression @let a | Just b <- match a = list in b@ the variable b will not+-- be in scope after the @in@. And besides, we would be on thin ice even if it was in+-- scope since we are referring to the pattern being bound in the guard that will+-- decide if the pattern will be bound... yikes, why does Haskell allow guards on +-- pattern binds to refer to the patterns being bound, could that ever lead to anything+-- but an infinite loop??+transformLetDecls :: [HsDecl] -> HsxM [HsDecl]+transformLetDecls ds = do+	-- We need to rename regular patterns in pattern bindings, since we need to+	-- separate the generated declaration sets. This since we need to add them not+	-- to the actual binding but rather to the declaration that will be the guard+	-- of the binding.+	let ds' = renameLetDecls ds +	transformLDs 0 0 ds'+  where transformLDs :: Int -> Int -> [HsDecl] -> HsxM [HsDecl]+  	transformLDs k l ds = case ds of+  	    []     -> return []+  	    (d:ds) -> case d of+  		HsPatBind srcloc pat rhs decls -> do+			-- We need to transform all pattern bindings in a set of+		  	-- declarations in the same context w.r.t. generating fresh+		  	-- variable names, since they will all be in scope at the same time.+		  	([pat'], ags, gs, ws, k', l') <- runTrFromTo k l (trPatterns [pat])+			decls' <- case decls of+			    -- Any declarations already in place should be left where they+			    -- are since they probably refer to the generating right-hand+			    -- side of the pattern bind. If they don't, we're in trouble...+			    HsBDecls decls -> fmap HsBDecls $ transformLetDecls decls+			    -- If they are implicit parameter bindings we simply transform+			    -- them as such.+			    HsIPBinds decls -> fmap HsIPBinds $ mapM transformIPBind decls+			-- The generated guard, if any, should be a declaration, and the+			-- generated declarations should be associated with it.+			let gs' = case gs of+				   []  -> []+				   [g] -> [mkDeclGuard g ws]+				   _   -> error "This should not happen since we \ +						   \ have called renameLetDecls already!"+			    -- Generated attribute guards should also be added as declarations,+			    -- but with no where clauses.+			    ags' = map (flip mkDeclGuard $ []) ags+			-- We must transform the right-hand side as well, but there are+			-- no new guards, nor any postponed patterns, to supply at this time.+			rhs' <- mkRhs srcloc [] [] rhs+			-- ... and then we should recurse with the new gensym argument.+			ds' <- transformLDs k' l' ds+			-- The generated guards, which should be at most one, should be+			-- added as declarations rather than as guards due to the+			-- scoping issue described above.+			return $ (HsPatBind srcloc pat' rhs' decls') : ags' ++ gs' ++ ds'++  	    	-- We only need to treat pattern binds separately, other declarations+  	    	-- can be transformed normally.+		d -> do d'  <- transformDecl d +			ds' <- transformLDs k l ds+			return $ d':ds'+++-- | Transform binding of implicit parameters by transforming the expression on the +-- right-hand side. The left-hand side can only be an implicit parameter, so no+-- regular patterns there...+transformIPBind :: HsIPBind -> HsxM HsIPBind+transformIPBind (HsIPBind s n e) =+	fmap (HsIPBind s n) $ transformExp e++------------------------------------------------------------------------------------+-- Statements of various kinds++-- | A simple annotation datatype for statement contexts.+data StmtType = Do | Guard | ListComp++-- | Transform statements by traversing and transforming subterms.+-- Since generator statements have slightly different semantics +-- depending on their context, statements are annotated with their+-- context to ensure that the semantics of the resulting statement+-- sequence is correct. The return type is a list since generated+-- guards will be added as statements on the same level as the+-- statement to be transformed.+transformStmt :: StmtType -> HsStmt -> HsxM [HsStmt]+transformStmt t s = case s of+	-- Generators can have regular patterns in the result pattern on the+	-- left-hand side and in the generating expression.+	HsGenerator s p e -> do+		let -- We need to treat generated guards differently depending+		    -- on the context of the statement.+		    guardFun = case t of+				Do	 -> monadify+				ListComp -> monadify+				Guard	 -> mkStmtGuard+		    -- Preserve semantics of irrefutable regular patterns by postponing+		    -- their evaluation to a let-expression on the right-hand side+		    ([p'], rnpss) = unzip $ renameIrrPats [p]+		-- Transform the pattern itself+		([p''], ags, gs, ds) <- transformPatterns [p']+		-- Put the generated declarations in a let-statement+		let lt  = case ds of+			   [] -> []+			   _  -> [letStmt ds]+		    -- Perform the designated trick on the generated guards.+		    gs' = map guardFun (ags ++ gs)+		-- Add the postponed patterns to the right-hand side by placing+		-- them in a let-expression to make them lazily evaluated.+		-- Then transform the whole right-hand side as an expression.+		e' <- transformExp $ addLetDecls s (concat rnpss) e+		return $ HsGenerator s p'' e':lt ++ gs'+	  where monadify :: Guard -> HsStmt+	  	-- To monadify is to create a statement guard, only that the+	  	-- generation must take place in a monad, so we need to "return"+	  	-- the value gotten from the guard.+		monadify (s,p,e) = genStmt s p (metaReturn $ paren e)+	-- Qualifiers are simply wrapped expressions and are treated as such.+	HsQualifier e -> fmap (\e -> [HsQualifier $ e]) $ transformExp e+	-- Let statements suffer from the same problem as let expressions, so+	-- the declarations should be treated in the same special way.+	HsLetStmt (HsBDecls ds)  -> +		fmap (\ds -> [letStmt ds]) $ transformLetDecls ds+	-- If the bindings are of implicit parameters we simply transform them as such.+	HsLetStmt (HsIPBinds is) -> +		fmap (\is -> [HsLetStmt (HsIPBinds is)]) $ mapM transformIPBind is+++------------------------------------------------------------------------------------------+-- Case alternatives++-- | Transform alternatives in a @case@-expression. Patterns are+-- transformed, while other subterms are traversed further.+transformAlt :: HsAlt -> HsxM HsAlt+transformAlt (HsAlt srcloc pat rhs decls) = do+	-- Preserve semantics of irrefutable regular patterns by postponing+	-- their evaluation to a let-expression on the right-hand side+  	let ([pat'], rnpss) = unzip $ renameIrrPats [pat]+  	-- Transform the pattern itself+  	([pat''], attrGuards, guards, decls'') <- transformPatterns [pat']+	-- Transform the right-hand side, and add any generated guards+	-- and let expressions to it.+  	rhs' <- mkGAlts srcloc (attrGuards ++ guards) (concat rnpss) rhs+	-- Transform declarations in the where clause, adding any generated+	-- declarations to it.+  	decls' <- case decls of+  		   HsBDecls ds -> do ds' <- mapM transformDecl ds+  		   		     return $ HsBDecls $ decls'' ++ ds+  		   _ 	       -> error "Cannot bind implicit parameters in the \+  		  		     \ \'where\' clause of a function using regular patterns."++	return $ HsAlt srcloc pat'' rhs' decls'+	+	-- Transform and update guards and right-hand side of a case-expression.+	-- The supplied list of guards is prepended to the original guards, and +	-- subterms are traversed and transformed.+  where	mkGAlts :: SrcLoc -> [Guard] -> [(HsName, HsPat)] -> HsGuardedAlts -> HsxM HsGuardedAlts+	mkGAlts s guards rnps (HsUnGuardedAlt rhs) = do+		-- Add the postponed patterns to the right-hand side by placing+		-- them in a let-expression to make them lazily evaluated.+		-- Then transform the whole right-hand side as an expression.+		rhs' <- transformExp $ addLetDecls s rnps rhs+		case guards of+		 -- There were no guards before, and none should be added,+		 -- so we still have an unguarded right-hand side+		 [] -> return $ HsUnGuardedAlt rhs'+		 -- There are guards to add. These should be added as pattern+		 -- guards, i.e. as statements.+		 _  -> return $ HsGuardedAlts [HsGuardedAlt s (map mkStmtGuard guards) rhs']+	mkGAlts s gs rnps (HsGuardedAlts galts) =+		fmap HsGuardedAlts $ mapM (mkGAlt gs rnps) galts+	  where mkGAlt :: [Guard] -> [(HsName, HsPat)] -> HsGuardedAlt -> HsxM HsGuardedAlt+		mkGAlt gs rnps (HsGuardedAlt s oldgs rhs) = do+			-- Add the postponed patterns to the right-hand side by placing+			-- them in a let-expression to make them lazily evaluated.+			-- Then transform the whole right-hand side as an expression.+			do rhs'   <- transformExp $ addLetDecls s rnps rhs+			    -- Now there are guards, so first we need to transform those+			   oldgs' <- fmap concat $ mapM (transformStmt Guard) oldgs+			    -- ... and then prepend the newly generated ones, as statements+			   return $ HsGuardedAlt s ((map mkStmtGuard gs) ++ oldgs') rhs'++----------------------------------------------------------------------------------+-- Guards++-- In some places, a guard will be a declaration instead of the+-- normal statement, so we represent it in a generic fashion.+type Guard = (SrcLoc, HsPat, HsExp)++mkStmtGuard :: Guard -> HsStmt+mkStmtGuard (s, p, e) = genStmt s p e++mkDeclGuard :: Guard -> [HsDecl] -> HsDecl+mkDeclGuard (s, p, e) ds = patBindWhere s p e ds++----------------------------------------------------------------------------------+-- Rewriting expressions before transformation.+-- Done in a monad for gensym capability.++newtype RN a = RN (RNState -> (a, RNState))++type RNState = Int++initRNState = 0++instance Monad RN where+ return a = RN $ \s -> (a,s)+ (RN f) >>= k = RN $ \s -> let (a,s') = f s+ 			       (RN g) = k a+ 			    in g s'++instance Functor RN where+ fmap f rna = do a <- rna+ 		 return $ f a+++runRename :: RN a -> a+runRename (RN f) = let (a,_) = f initRNState+		    in a++getRNState :: RN RNState+getRNState = RN $ \s -> (s,s)++setRNState :: RNState -> RN ()+setRNState s = RN $ \_ -> ((), s)++genVarName :: RN HsName+genVarName = do +	k <- getRNState+	setRNState $ k+1+	return $ name $ "harp_rnvar" ++ show k+++type NameBind = (HsName, HsPat)++-- Some generic functions on monads for traversing subterms++rename1pat :: a -> (b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+rename1pat p f rn = do (q, ms) <- rn p+		       return (f q, ms)++rename2pat :: a -> a -> (b -> b -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+rename2pat p1 p2 f rn = do (q1, ms1) <- rn p1+			   (q2, ms2) <- rn p2+			   return $ (f q1 q2, ms1 ++ ms2)+			+renameNpat :: [a] -> ([b] -> c) -> (a -> RN (b, [d])) -> RN (c, [d])+renameNpat ps f rn = do (qs, mss) <- fmap unzip $ mapM rn ps+			return (f qs, concat mss)+++++-- | Generate variables as placeholders for any regular patterns, in order+-- to place their evaluation elsewhere. We must likewise move the evaluation+-- of Tags because attribute lookups are force evaluation.+renameRPats :: [HsPat] -> [(HsPat, [NameBind])]+renameRPats ps = runRename $ mapM renameRP ps++renameRP :: HsPat -> RN (HsPat, [NameBind])+renameRP p = case p of+	-- We must rename regular patterns and Tag expressions+	HsPRPat _ _ 	    -> rename p+	HsPXTag _ _ _ _ _   -> rename p+	HsPXETag _ _ _ _    -> rename p+	-- The rest of the rules simply try to rename regular patterns in+	-- their immediate subpatterns.+	HsPNeg p    	    -> rename1pat p HsPNeg renameRP+	HsPInfixApp p1 n p2 -> rename2pat p1 p2+				(\p1 p2 -> HsPInfixApp p1 n p2)+				renameRP+	HsPApp n ps	    -> renameNpat ps (HsPApp n) renameRP+	HsPTuple ps	    -> renameNpat ps HsPTuple renameRP+	HsPList ps	    -> renameNpat ps HsPList renameRP+	HsPParen p	    -> rename1pat p HsPParen renameRP+	HsPRec n pfs	    -> renameNpat pfs (HsPRec n) renameRPf+	HsPAsPat n p	    -> rename1pat p (HsPAsPat n) renameRP+	HsPIrrPat p	    -> rename1pat p HsPIrrPat renameRP+	HsPXPatTag p	    -> rename1pat p HsPXPatTag renameRP+	HsPatTypeSig s p t  -> rename1pat p (\p -> HsPatTypeSig s p t) renameRP	+	_		    -> return (p, [])++  where renameRPf :: HsPatField -> RN (HsPatField, [NameBind])+  	renameRPf (HsPFieldPat n p) = rename1pat p (HsPFieldPat n) renameRP+  	+  	renameAttr :: HsPXAttr -> RN (HsPXAttr, [NameBind])+  	renameAttr (HsPXAttr s p) = rename1pat p (HsPXAttr s) renameRP+  	+  	rename :: HsPat -> RN (HsPat, [NameBind])+  	rename p = do -- Generate a fresh variable+  		      n <- genVarName+  		      -- ... and return that, along with the association of+		      -- the variable with the old pattern+  		      return (pvar n, [(n,p)])++-- | Rename declarations appearing in @let@s or @where@ clauses.+renameLetDecls :: [HsDecl] -> [HsDecl]+renameLetDecls ds = +	let -- Rename all regular patterns bound in pattern bindings.+	    (ds', smss) = unzip $ runRename $ mapM renameLetDecl ds+	    -- ... and then generate declarations for the associations+	    gs = map (\(s,n,p) -> mkDecl s (n,p)) (concat smss)+	    -- ... which should be added to the original list of declarations.+	 in ds' ++ gs++  where	renameLetDecl :: HsDecl -> RN (HsDecl, [(SrcLoc, HsName, HsPat)])+	renameLetDecl d = case d of+		-- We need only bother about pattern bindings.+		HsPatBind srcloc pat rhs decls -> do+			-- Rename any regular patterns that appear in the+			-- pattern being bound.+			(p, ms) <- renameRP pat+			let sms = map (\(n,p) -> (srcloc, n, p)) ms+			return $ (HsPatBind srcloc p rhs decls, sms)+		_ -> return (d, [])+++-- | Move irrefutable regular patterns into a @let@-expression instead,+-- to make sure that the semantics of @~@ are preserved.+renameIrrPats :: [HsPat] -> [(HsPat, [NameBind])]+renameIrrPats ps = runRename (mapM renameIrrP ps)++renameIrrP :: HsPat -> RN (HsPat, [(HsName, HsPat)])+renameIrrP p = case p of+	-- We should rename any regular pattern appearing+	-- inside an irrefutable pattern.+	HsPIrrPat p	    -> do (q, ms) <- renameRP p+				  return $ (HsPIrrPat q, ms)+	-- The rest of the rules simply try to rename regular patterns in+	-- irrefutable patterns in their immediate subpatterns.+	HsPNeg p    	    -> rename1pat p HsPNeg renameIrrP+	HsPInfixApp p1 n p2 -> rename2pat p1 p2+				(\p1 p2 -> HsPInfixApp p1 n p2)+				renameIrrP+	HsPApp n ps	    -> renameNpat ps (HsPApp n) renameIrrP+	HsPTuple ps	    -> renameNpat ps HsPTuple renameIrrP+	HsPList ps	    -> renameNpat ps HsPList renameIrrP+	HsPParen p	    -> rename1pat p HsPParen renameIrrP+	HsPRec n pfs	    -> renameNpat pfs (HsPRec n) renameIrrPf+	HsPAsPat n p	    -> rename1pat p (HsPAsPat n) renameIrrP+	HsPatTypeSig s p t  -> rename1pat p (\p -> HsPatTypeSig s p t) renameIrrP	++	-- Hsx+	HsPXTag s n attrs mat p -> do (attrs', nss) <- fmap unzip $ mapM renameIrrAttr attrs+				      (mat', ns1) <- case mat of+				      	       	      Nothing -> return (Nothing, [])+				      	              Just at -> do (at', ns) <- renameIrrP at+				      	              		    return (Just at', ns)+				      (q, ns) <- rename1pat p (HsPXTag s n attrs' mat') renameIrrP+				      return (q, concat nss ++ ns1 ++ ns)+	HsPXETag s n attrs mat	-> do (as, nss) <- fmap unzip $ mapM renameIrrAttr attrs+				      (mat', ns1) <- case mat of+				      	       	      Nothing -> return (Nothing, [])+				      	              Just at -> do (at', ns) <- renameIrrP at+				      	              		    return (Just at', ns)+				      return $ (HsPXETag s n as mat', concat nss ++ ns1)+	HsPXPatTag p	    	-> rename1pat p HsPXPatTag renameIrrP+	-- End Hsx++	_		    -> return (p, [])+	+  where renameIrrPf :: HsPatField -> RN (HsPatField, [NameBind])+  	renameIrrPf (HsPFieldPat n p) = rename1pat p (HsPFieldPat n) renameIrrP+  	+  	renameIrrAttr :: HsPXAttr -> RN (HsPXAttr, [NameBind])+  	renameIrrAttr (HsPXAttr s p) = rename1pat p (HsPXAttr s) renameIrrP+-----------------------------------------------------------------------------------+-- Transforming Patterns: the real stuff++-- | Transform several patterns in the same context, thereby+-- generating any code for matching regular patterns.+transformPatterns :: [HsPat] -> HsxM ([HsPat], [Guard], [Guard], [HsDecl])+transformPatterns ps = runTr (trPatterns ps)++---------------------------------------------------+-- The transformation monad++type State = (Int, Int, Int, [Guard], [Guard], [HsDecl])++newtype Tr a = Tr (State -> HsxM (a, State))++instance Monad Tr where+ return a = Tr $ \s -> return (a, s)+ (Tr f) >>= k = Tr $ \s ->+ 		  do (a, s') <- f s+ 		     let (Tr f') = k a+ 		     f' s'++instance Functor Tr where+ fmap f tra = tra >>= (return . f)++liftTr :: HsxM a -> Tr a+liftTr hma = Tr $ \s -> do a <- hma+			   return (a, s)++initState = initStateFrom 0 0++initStateFrom k l = (0, k, l, [], [], [])++runTr :: Tr a -> HsxM (a, [Guard], [Guard], [HsDecl])+runTr (Tr f) = do (a, (_,_,_,gs1,gs2,ds)) <- f initState+		  return (a, reverse gs1, reverse gs2, reverse ds)+++runTrFromTo :: Int -> Int -> Tr a -> HsxM (a, [Guard], [Guard], [HsDecl], Int, Int)+runTrFromTo k l (Tr f) = do (a, (_,k',l',gs1,gs2,ds)) <- f $ initStateFrom k l+			    return (a, reverse gs1, reverse gs2, reverse ds, k', l')+++-- manipulating the state+getState :: Tr State+getState = Tr $ \s -> return (s,s)++setState :: State -> Tr ()+setState s = Tr $ \_ -> return ((),s)++updateState :: (State -> (a,State)) -> Tr a+updateState f = do s <- getState+		   let (a,s') = f s+		   setState s'+		   return a++-- specific state manipulating functions+pushGuard :: SrcLoc -> HsPat -> HsExp -> Tr ()+pushGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,(s,p,e):gs2,ds))+		 +pushDecl :: HsDecl -> Tr ()+pushDecl d = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,gs1,gs2,d:ds))++pushAttrGuard :: SrcLoc -> HsPat -> HsExp -> Tr ()+pushAttrGuard s p e = updateState $ \(n,m,a,gs1,gs2,ds) -> ((),(n,m,a,(s,p,e):gs1,gs2,ds))++genMatchName :: Tr HsName+genMatchName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (n,(n+1,m,a,gs1,gs2,ds))+		  return $ HsIdent $ "harp_match" ++ show k++genPatName :: Tr HsName+genPatName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m+1,a,gs1,gs2,ds))+		return $ HsIdent $ "harp_pat" ++ show k++genAttrName :: Tr HsName+genAttrName = do k <- updateState $ \(n,m,a,gs1,gs2,ds) -> (m,(n,m,a+1,gs1,gs2,ds))+		 return $ HsIdent $ "hsx_attrs" ++ show k+++setHarpTransformedT, setXmlTransformedT :: Tr ()+setHarpTransformedT = liftTr setHarpTransformed+setXmlTransformedT  = liftTr setXmlTransformed+++-------------------------------------------------------------------+-- Some generic functions for computations in the Tr monad. Could+-- be made even more general, but there's really no point right now...++tr1pat :: a -> (b -> c) -> (a -> Tr b) -> Tr c+tr1pat p f tr = do q <- tr p+		   return $ f q++tr2pat :: a -> a -> (b -> b -> c) -> (a -> Tr b) -> Tr c+tr2pat p1 p2 f tr = do q1 <- tr p1+		       q2 <- tr p2+		       return $ f q1 q2++trNpat :: [a] -> ([b] -> c) -> (a -> Tr b) -> Tr c+trNpat ps f tr = do qs <- mapM tr ps+		    return $ f qs++-----------------------------------------------------------------------------+-- The *real* transformations+-- Transforming patterns++-- | Transform several patterns in the same context+trPatterns :: [HsPat] -> Tr [HsPat]+trPatterns = mapM trPattern++-- | Transform a pattern by traversing the syntax tree.+-- A regular pattern is translated, other patterns are +-- simply left as is.+trPattern :: HsPat -> Tr HsPat+trPattern p = case p of+	-- This is where the fun starts. =)+	-- Regular patterns must be transformed of course.+	HsPRPat s rps -> do+		-- First we need a name for the placeholder pattern.+		n <- genPatName +		-- A top-level regular pattern is a sequence in linear+		-- context, so we can simply translate it as if it was one.+		(mname, vars, _) <- trRPat s True (HsRPSeq rps)+		-- Generate a top level declaration.+		topmname <- mkTopDecl s mname vars+		-- Generate a pattern guard for this regular pattern,+		-- that will match the generated declaration to the +		-- value of the placeholder, and bind all variables.+		mkGuard s vars topmname n+		-- And indeed, we have made a transformation!+		setHarpTransformedT+		-- Return the placeholder pattern.+		return $ pvar n+	-- Tag patterns should be transformed+	HsPXTag s name attrs mattr cpat -> do+		-- We need a name for the attribute list, if there are lookups+		an <- case (mattr, attrs) of+			-- ... if there is one already, and there are no lookups+			-- we can just return that+			(Just ap, []) -> return $ ap+			      -- ... if there are none, we dont' care+			(_, []) -> return wildcard+			(_, _)  -> do -- ... but if there are, we want a name for that list+				      n <- genAttrName+				      -- ... we must turn attribute lookups into guards+				      mkAttrGuards s n attrs mattr+				      -- ... and we return the pattern+				      return $ pvar n+		-- ... the pattern representing children should be transformed+		cpat' <- trPattern cpat+		-- ...  we have made a transformation and should report that+		setHarpTransformedT+		-- ... and we return a Tag pattern.+		let (dom, n) = xNameParts name+		return $ metaTag dom n an cpat' +	-- ... as should empty Tag patterns+	HsPXETag s name attrs mattr -> do+		-- We need a name for the attribute list, if there are lookups+		an <- case (mattr, attrs) of+			-- ... if there is a pattern already, and there are no lookups+			-- we can just return that+			(Just ap, []) -> return $ ap+			      -- ... if there are none, we dont' care+			(_, []) -> return wildcard+			(_, _)  -> do -- ... but if there are, we want a name for that list+				      n <- genAttrName+				      -- ... we must turn attribute lookups into guards+				      mkAttrGuards s n attrs mattr+				      -- ... and we return the pattern+				      return $ pvar n+		-- ...  we have made a transformation and should report that+		setHarpTransformedT+		-- ... and we return an ETag pattern.+		let (dom, n) = xNameParts name+		return $ metaTag dom n an peList+	-- PCDATA patterns are strings in the xml datatype.+	HsPXPcdata s -> setHarpTransformedT >> (return $ metaPcdata s)+	-- XML comments are likewise just treated as strings.+	HsPXPatTag p -> setHarpTransformedT >> trPattern p++	-- Transforming any other patterns simply means transforming+	-- their subparts.+	HsPVar _	     -> return p+	HsPLit _	     -> return p+	HsPNeg q	     -> tr1pat q HsPNeg trPattern+	HsPInfixApp p1 op p2 -> tr2pat p1 p2 (\p1 p2 -> HsPInfixApp p1 op p2) trPattern+	HsPApp n ps	     -> trNpat ps (HsPApp n) trPattern+	HsPTuple ps	     -> trNpat ps HsPTuple trPattern+	HsPList ps	     -> trNpat ps HsPList trPattern+	HsPParen p	     -> tr1pat p HsPParen trPattern+	HsPRec n pfs	     -> trNpat pfs (HsPRec n) trPatternField+	HsPAsPat n p	     -> tr1pat p (HsPAsPat n) trPattern+	HsPWildCard	     -> return p+	HsPIrrPat p	     -> tr1pat p HsPIrrPat trPattern+	HsPatTypeSig s p t   -> tr1pat p (\p -> HsPatTypeSig s p t) trPattern++  where	-- Transform a pattern field.+  	trPatternField :: HsPatField -> Tr HsPatField+  	trPatternField (HsPFieldPat n p) = +  		tr1pat p (HsPFieldPat n) trPattern+ +	-- Deconstruct an xml tag name into its parts.+	xNameParts :: HsXName -> (Maybe String, String)+	xNameParts n = case n of+			HsXName s      -> (Nothing, s)+			HsXDomName d s -> (Just d, s)++	-- | Generate a guard for looking up xml attributes.+	mkAttrGuards :: SrcLoc -> HsName -> [HsPXAttr] -> Maybe HsPat -> Tr ()+	mkAttrGuards s attrs [HsPXAttr n q] mattr = do+		-- Apply lookupAttr to the attribute name and+		-- attribute set+		let rhs = metaExtract n attrs+		    -- ... catch the result+		    pat = metaPJust q+		    -- ... catch the remainder list+		    rml = case mattr of+		    	   Nothing -> wildcard+		    	   Just ap -> ap+		-- ... and add the generated guard to the store.+		pushAttrGuard s (pTuple [pat, rml]) rhs++	mkAttrGuards s attrs ((HsPXAttr a q):xs) mattr = do+		-- Apply lookupAttr to the attribute name and+		-- attribute set+		let rhs = metaExtract a attrs+		    -- ... catch the result+		    pat = metaPJust q+		-- ... catch the remainder list+		newAttrs <- genAttrName+		-- ... and add the generated guard to the store.+		pushAttrGuard s (pTuple [pat, pvar newAttrs]) rhs+		-- ... and finally recurse+		mkAttrGuards s newAttrs xs mattr+		    + 	-- | Generate a declaration at top level that will finalise all + 	-- variable continuations, and then return all bound variables.+	mkTopDecl :: SrcLoc -> HsName -> [HsName] -> Tr HsName+	mkTopDecl s mname vars = +		do -- Give the match function a name+		   n <- genMatchName +		   -- Create the declaration and add it to the store.+		   pushDecl $ topDecl s n mname vars+		   -- Return the name of the match function so that the+		   -- guard that will be generated can call it.+		   return n++	topDecl :: SrcLoc -> HsName -> HsName -> [HsName] -> HsDecl+	topDecl s n mname vs = +		let pat  = pTuple [wildcard, pvarTuple vs]	-- (_, (foo, bar, ...))+		    g    = var mname				-- harp_matchX+		    a    = genStmt s pat g			-- (_, (foo, ...)) <- harp_matchX+		    vars = map (\v -> app (var v) eList) vs	-- (foo [], bar [], ...)+		    b    = qualStmt $ metaReturn $ tuple vars	-- return (foo [], bar [], ...)+		    e    = doE [a,b]				-- do (...) <- harp_matchX+		    						--    return (foo [], bar [], ...)+	 	 in nameBind s n e		-- harp_matchY = do ....++	-- | Generate a pattern guard that will apply the @runMatch@+	-- function on the top-level match function and the input list,+	-- thereby binding all variables.+	mkGuard :: SrcLoc -> [HsName] -> HsName -> HsName -> Tr ()+	mkGuard s vars mname n = do+		let tvs = pvarTuple vars				-- (foo, bar, ...)+		    ge  = appFun runMatchFun [var mname, var n]		-- runMatch harp_matchX harp_patY+		pushGuard s (pApp just_name [tvs]) ge			-- Just (foo, bar, ...) , runMatch ...+++--------------------------------------------------------------------------------+-- Transforming regular patterns++-- | A simple datatype to annotate return values from sub-patterns+data MType = S		   -- Single element+	   | L MType	   -- List of ... , (/  /), *, ++	   | E MType MType -- Either ... or ... , (  |  )+	   | M MType	   -- Maybe ... , ?+++-- When transforming a regular sub-pattern, we need to know the+-- name of the function generated to match it, the names of all+-- variables it binds, and the type of its returned value.+type MFunMetaInfo = (HsName, [HsName], MType)+++-- | Transform away a regular pattern, generating code+-- to replace it.+trRPat :: SrcLoc -> Bool -> HsRPat -> Tr MFunMetaInfo+trRPat s linear rp = case rp of+    -- For an ordinary Haskell pattern we need to generate a+    -- base match function for the pattern, and a declaration+    -- that lifts that function into the matcher monad.+    HsRPPat p -> do mkBaseDecl s linear p+  +      where -- | Generate declarations for matching ordinary Haskell patterns+	    mkBaseDecl :: SrcLoc -> Bool -> HsPat -> Tr MFunMetaInfo+	    mkBaseDecl s linear p = case p of+		-- We can simplify a lot if the pattern is a wildcard or a variable+		HsPWildCard -> mkWCMatch s+		HsPVar v    -> mkVarMatch s linear v+		-- ... and if it is an embedded pattern tag, we can just skip it+		HsPXPatTag q -> mkBaseDecl s linear q++		-- ... otherwise we'll have to take the long way...+		p           -> do -- First do a case match on a single element+				  (name, vars, _) <- mkBasePat s linear p	+				  -- ... apply baseMatch to the case matcher to +				  -- lift it into the matcher monad.+				  newname <- mkBaseMatch s name	+				  -- ... and return the meta-info gathered.+				  return (newname, vars, S)++	    -- | Generate a declaration for matching a variable.+	    mkVarMatch :: SrcLoc -> Bool -> HsName -> Tr MFunMetaInfo+	    mkVarMatch s linear v = do+		-- First we need a name for the new match function.+		n <- genMatchName+		-- Then we need a basic matching function that always matches,+		-- and that binds the value matched to the variable in question.+		let e = paren $ lamE s [pvar v] $		-- (\v -> Just (mf v))+				  app (var just_name) +				  (paren $ retVar linear v)+		-- Lift the function into the matcher monad, and bind it to its name,+		-- then add it the declaration to the store.+		pushDecl $ nameBind s n $+			      app baseMatchFun e	-- harp_matchX = baseMatch (\v -> Just (mf v))+		return (n, [v], S)			-- always binds v and only v++	      where retVar :: Bool -> HsName -> HsExp+		    retVar linear v +		    	-- if bound in linear context, apply const+			| linear    = metaConst (var v)+			-- if bound in non-linear context, apply (:)+			| otherwise = app consFun (var v)   ++	    -- | Generate a declaration for matching a wildcard+	    mkWCMatch :: SrcLoc -> Tr MFunMetaInfo+	    mkWCMatch s = do +		-- First we need a name...+		n <- genMatchName+		-- ... and then a function that always matches, discarding the result+		let e = paren $ lamE s [wildcard] $ 	-- (\_ -> Just ())+				    app (var just_name) unit_con+		-- ... which we lift, bind, and add to the store.+		pushDecl $ nameBind s n $ 		-- harp_matchX = baseMatch (\_ -> Just ())+			     app baseMatchFun e+		return (n, [], S)	-- no variables bound, hence []++	    -- | Generate a basic function that cases on a single element, +	    -- returning Just (all bound variables) on a match, and+	    -- Nothing on a mismatch.+	    mkBasePat :: SrcLoc -> Bool -> HsPat -> Tr MFunMetaInfo+	    mkBasePat s b p = +		do -- First we need a name...+		   n <- genMatchName+		   -- ... and then we need to know what variables that +		   -- will be bound by this match.+		   let vs = gatherPVars p+		   -- ... and then we can create and store away a casing function.+		   basePatDecl s b n vs p >>= pushDecl+		   return (n, vs, S)++	      where -- | Gather up the names of all variables in a pattern,+		    -- using a simple fold over the syntax structure.+		    gatherPVars :: HsPat -> [HsName]+		    gatherPVars p = case p of+			HsPVar v	     -> [v]+			HsPNeg q	     -> gatherPVars q+			HsPInfixApp p1 _ p2  -> gatherPVars p1 +++						 gatherPVars p2+			HsPApp _ ps	     -> concatMap gatherPVars ps +			HsPTuple ps	     -> concatMap gatherPVars ps +			HsPList ps	     -> concatMap gatherPVars ps +			HsPParen p	     -> gatherPVars p+			HsPRec _ pfs	     -> concatMap help pfs+				where help (HsPFieldPat _ p) = gatherPVars p+			HsPAsPat n p	     -> n : gatherPVars p+			HsPWildCard	     -> []+			HsPIrrPat p	     -> gatherPVars p+			HsPatTypeSig _ p _   -> gatherPVars p+			HsPRPat _ rps	     -> concatMap gatherRPVars rps+			HsPXTag _ _ attrs mattr cp -> +				concatMap gatherAttrVars attrs ++ gatherPVars cp +++					case mattr of+					 Nothing -> []+					 Just ap -> gatherPVars ap+			HsPXETag _ _ attrs mattr -> +				concatMap gatherAttrVars attrs ++ +					case mattr of+					 Nothing -> []+					 Just ap -> gatherPVars ap+			HsPXPatTag p	     -> gatherPVars p+			_		     -> []++		    gatherRPVars :: HsRPat -> [HsName]+		    gatherRPVars rp = case rp of+			HsRPStar rq	   -> gatherRPVars rq+			HsRPStarG rq	   -> gatherRPVars rq+			HsRPPlus rq 	   -> gatherRPVars rq+			HsRPPlusG rq	   -> gatherRPVars rq+			HsRPOpt rq	   -> gatherRPVars rq+			HsRPOptG rq	   -> gatherRPVars rq+			HsRPEither rq1 rq2 -> gatherRPVars rq1 ++ gatherRPVars rq2+			HsRPSeq rqs	   -> concatMap gatherRPVars rqs+			HsRPCAs n rq	   -> n : gatherRPVars rq+			HsRPAs n rq	   -> n : gatherRPVars rq+			HsRPParen rq	   -> gatherRPVars rq+			HsRPPat q	   -> gatherPVars q+		+		    gatherAttrVars :: HsPXAttr -> [HsName]+		    gatherAttrVars (HsPXAttr _ p) = gatherPVars p++	    -- | Generate a basic casing function for a given pattern.	+	    basePatDecl :: SrcLoc -> Bool -> HsName -> [HsName] -> HsPat -> Tr HsDecl+	    basePatDecl s linear f vs p = do+		-- We can use the magic variable harp_a since nothing else needs to+		-- be in scope at this time (we could use just a, or foo, or whatever)+		let a = HsIdent $ "harp_a"+		-- ... and we should case on that variable on the right-hand side.+		rhs <- baseCaseE s linear p a vs	-- case harp_a of ...+		-- The result is a simple function with one paramenter and+		-- the right-hand side we just generated.+		return $ simpleFun s f a rhs+	      where baseCaseE :: SrcLoc -> Bool -> HsPat -> HsName -> [HsName] -> Tr HsExp+		    baseCaseE s b p a vs = do+			-- First the alternative if we actually +			-- match the given pattern+			let alt1 = alt s p 				    -- foo -> Just (mf foo)+				    (app (var just_name) $ +				     tuple (map (retVar b) vs))+			    -- .. and finally an alternative for not matching the pattern.+			    alt2 = alt s wildcard (var nothing_name)	    -- _ -> Nothing+			-- ... and that pattern could itself contain regular patterns+			-- so we must transform away these.+			alt1' <- liftTr $ transformAlt alt1+			return $ caseE (var a) [alt1', alt2]+		    retVar :: Bool -> HsName -> HsExp+		    retVar linear v+		        -- if bound in linear context, apply const+			| linear    = metaConst (var v)+			-- if bound in non-linear context, apply (:)+			| otherwise = app consFun (var v)++	    -- | Generate a match function that lift the result of the+	    -- basic casing function into the matcher monad.+	    mkBaseMatch :: SrcLoc -> HsName -> Tr HsName+	    mkBaseMatch s name = +		do -- First we need a name...+		   n <- genMatchName+		   -- ... to which we bind the lifting function+		   pushDecl $ baseMatchDecl s n name+		   -- and then return for others to use.+		   return n++	    -- | Generate a declaration for the function that lifts a simple+	    -- casing function into the matcher monad.+	    baseMatchDecl :: SrcLoc -> HsName -> HsName -> HsDecl+	    baseMatchDecl s newname oldname = +		-- Apply the lifting function "baseMatch" to the casing function+		let e = app baseMatchFun (var oldname)+		    -- ... and bind it to the new name.+		 in nameBind s newname e		-- harp_matchX = baseMatch harp_matchY+++    -- For a sequence of regular patterns, we should transform all+    -- sub-patterns and then generate a function for sequencing them.+    HsRPSeq rps -> do +    	nvts <- mapM (trRPat s linear) rps+	mkSeqDecl s nvts+	+      where -- | Generate a match function for a sequence of regular patterns,+	    -- flattening any special sub-patterns into normal elements of the list+	    mkSeqDecl :: SrcLoc -> [MFunMetaInfo] -> Tr MFunMetaInfo+	    mkSeqDecl s nvts = do+	    	-- First, as always, we need a name...+		name <- genMatchName+	     	let -- We need a generating statement for each sub-pattern.+	     	    (gs, vals) = unzip $ mkGenExps s 0 nvts		-- (harp_valX, (foo, ...)) <- harp_matchY+	     	    -- Gather up all variables from all sub-patterns.+		    vars    = concatMap (\(_,vars,_) -> vars) nvts+		    -- ... flatten all values to simple lists, and concatenate+		    -- the lists to a new return value+		    fldecls = flattenVals s vals			-- harp_valXf = $flatten harp_valX+		    							-- harp_ret = foldComp [harp_val1f, ...]+		    -- ... return the value along with all variables+		    ret     = qualStmt $ metaReturn $			-- return (harp_ret, (foo, .....))+		    		tuple [var retname, varTuple vars]+		    -- ... do all these steps in a do expression+		    rhs	    = doE $ gs ++ 				-- do (harp_valX, (foo, ...)) <- harpMatchY+				[letStmt fldecls, ret]			--    let harp_valXf = $flatten harp_valX+									--    return (harp_ret, (foo, .....))+		-- ... bind it to its name, and add the declaration+		-- to the store.+		pushDecl $ nameBind s name rhs 				-- harp_matchZ = do ....+		-- The return value of a sequence is always a list of elements.+		return (name, vars, L S)++	    -- | Flatten values of all sub-patterns into normal elements of the list+	    flattenVals :: SrcLoc -> [(HsName, MType)] -> [HsDecl]+	    flattenVals s nts = +		let -- Flatten the values of all sub-patterns to +		    -- lists of elements+		    (nns, ds) = unzip $ map (flVal s) nts+		    -- ... and concatenate their results.+		    ret       = nameBind s retname $ app+				  (paren $ app foldCompFun +				    (listE $ map var nns)) $ eList+		 in ds ++ [ret]+	+	+	    flVal :: SrcLoc -> (HsName, MType) -> (HsName, HsDecl)+	    flVal s (name, mt) =+		let -- We reuse the old names, we just extend them a bit.+		    newname = extendVar name "f"	-- harp_valXf+		    -- Create the appropriate flattening function depending+		    -- on the type of the value+		    f       = flatten mt+		    -- ... apply it to the value and bind it to its new name.+		 in (newname, nameBind s newname $	-- harp_valXf = $flatten harp_valX+				app f (var name))++	    -- | Generate a flattening function for a given type structure.+	    flatten :: MType -> HsExp+	    flatten S = consFun				-- (:)+	    flatten (L mt) = +		let f = flatten mt+		    r = paren $ metaMap f+		 in paren $ foldCompFun	`metaComp` r	-- (foldComp . (map $flatten))+	    flatten (E mt1 mt2) = +		let f1 = flatten mt1+		    f2 = flatten mt2+		 in paren $ metaEither f1 f2		-- (either $flatten $flatten)+	    flatten (M mt) = +		let f = flatten mt+		 in paren $ metaMaybe idFun f		-- (maybe id $flatten)++    -- For accumulating as-patterns we should transform the subpattern, and then generate +    -- a declaration that supplies the value to be bound to the variable in question.+    -- The variable should be bound non-linearly.+    HsRPCAs v rp -> do +    	-- Transform the subpattern+    	nvt@(name, vs, mt) <- trRPat s linear rp+    	-- ... and create a declaration to bind its value.+	n <- mkCAsDecl s nvt+	-- The type of the value is unchanged.+	return (n, (v:vs), mt)++      where -- | Generate a declaration for a @: binding.+	    mkCAsDecl :: SrcLoc -> MFunMetaInfo -> Tr HsName+	    mkCAsDecl = asDecl $ app consFun	-- should become lists when applied to []+++    -- For ordinary as-patterns we should transform the subpattern, and then generate +    -- a declaration that supplies the value to be bound to the variable in question.+    -- The variable should be bound linearly.+    HsRPAs v rp +	| linear -> +	     do -- Transform the subpattern+		nvt@(name, vs, mt) <- trRPat s linear rp+		-- ... and create a declaration to bind its value+		n <- mkAsDecl s nvt+		-- The type of the value is unchanged.+		return (n, (v:vs), mt)+	-- We may not use an @ bind in non-linear context+	| otherwise -> case v of+		    	HsIdent n -> fail $ "Attempting to bind variable "++n+++					  " inside the context of a numerable regular pattern"+		    	_	      -> fail $ "This should never ever ever happen...\+						  \ how the #% did you do it??!?"++      where -- | Generate a declaration for a @ binding.+	    mkAsDecl :: SrcLoc -> MFunMetaInfo -> Tr HsName+	    mkAsDecl = asDecl metaConst		-- should be constant when applied to []+++    -- For regular patterns, parentheses have no real meaning+    -- so at this point we can just skip them.+    HsRPParen rp -> trRPat s linear rp+    +    -- For (possibly non-greedy) optional regular patterns we need to+    -- transform the subpattern, and the generate a function that can+    -- choose to match or not to match, that is the question...+    HsRPOpt rp -> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can optionally match it.+	   mkOptDecl s False nvt+    -- ... similarly for the non-greedy version.+    HsRPOptG rp -> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can optionally match it.+	   mkOptDecl s True nvt+++    -- For union patterns, we should transform both subexpressions,+    -- and generate a function that chooses between them.+    HsRPEither rp1 rp2 -> +    	do -- Transform the subpatterns+    	   nvt1 <- trRPat s False rp1+	   nvt2 <- trRPat s False rp2+	   -- ... and create a declaration that can choose between them.+	   mkEitherDecl s nvt1 nvt2+  	-- | Generate declarations for either patterns, i.e. ( | )+      where mkEitherDecl :: SrcLoc -> MFunMetaInfo -> MFunMetaInfo -> Tr MFunMetaInfo+            mkEitherDecl s nvt1@(_, vs1, t1) nvt2@(_, vs2, t2) = do+                -- Eine namen, bitte!+  		n <- genMatchName+  		let -- Generate generators for the subpatterns+  		    (g1, v1) = mkGenExp s nvt1+  		    (g2, v2) = mkGenExp s nvt2			-- (harp_valX, (foo, bar, ...)) <- harp_matchY+  		    -- ... gather all variables from both sides+  		    allvs = vs1 `union` vs2+  		    -- ... some may be bound on both sides, so we+  		    -- need to check which ones are bound on each,+  		    -- supplying empty value for those that are not+  		    vals1 = map (varOrId vs1) allvs		+  		    vals2 = map (varOrId vs2) allvs+  		    -- ... apply either Left or Right to the returned value+  		    ret1  = metaReturn $ tuple			-- return (Left harp_val1, (foo, id, ...))+  		    		[app (var left_name)+  		    		 (var v1), tuple vals1]+  		    ret2  = metaReturn $ tuple			-- return (Right harp_val2, (id, bar, ...))+  		    		[app (var right_name)+  		    		 (var v2), tuple vals2]+  		    -- ... and do all these things in do-expressions+  		    exp1  = doE [g1, qualStmt ret1]+  		    exp2  = doE [g2, qualStmt ret2]+  		    -- ... and choose between them using the choice (+++) operator.+  		    rhs   = (paren exp1) `metaChoice`		-- (do ...) +++ +  		    		(paren exp2)			--  (do ...)+  		-- Finally we create a declaration for this function and+  		-- add it to the store.+  		pushDecl $ nameBind s n rhs			-- harp_matchZ = (do ...) ...+  		-- The type of the returned value is Either the type of the first+  		-- or the second subpattern.+  		return (n, allvs, E t1 t2)+  		 +	    varOrId :: [HsName] -> HsName -> HsExp+	    varOrId vs v = if v `elem` vs 	-- the variable is indeed bound in this branch+	  			then var v 	-- ... so it should be added to the result+	  			else idFun	-- ... else it should be empty.++    -- For (possibly non-greedy) repeating regular patterns we need to transform the subpattern,+    -- and then generate a function to handle many matches of it.+    HsRPStar rp	-> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can match it many times.+	   mkStarDecl s False nvt+    -- ... and similarly for the non-greedy version.+    HsRPStarG rp -> +    	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+    	   -- ... and create a declaration that can match it many times.+	   mkStarDecl s True nvt++    -- For (possibly non-greedy) non-empty repeating patterns we need to transform the subpattern,+    -- and then generate a function to handle one or more matches of it.+    HsRPPlus rp	-> +	do -- Transform the subpattern+	   nvt <- trRPat s False rp+	   -- ... and create a declaration that can match it one or more times.+	   mkPlusDecl s False nvt+    -- ... and similarly for the non-greedy version.+    HsRPPlusG rp -> +	do -- Transform the subpattern+    	   nvt <- trRPat s False rp+	   -- ... and create a declaration that can match it one or more times.+	   mkPlusDecl s True nvt+++  where -- These are the functions that must be in scope for more than one case alternative above.+  +  	-- | Generate the generators that call sub-matching functions, and+	-- annotate names with types for future flattening of values.+	-- Iterate to enable gensym-like behavior.+	mkGenExps :: SrcLoc -> Int -> [MFunMetaInfo] -> [(HsStmt, (HsName, MType))]+	mkGenExps _ _ [] = []+	mkGenExps s k ((name, vars, t):nvs) = +		let valname = mkValName k				-- harp_valX+		    pat     = pTuple [pvar valname, pvarTuple vars]	-- (harp_valX, (foo, bar, ...))+		    g	    = var name+		 in (genStmt s pat g, (valname, t)) : 			-- (harp_valX, (foo, ...)) <- harp_matchY+		 	mkGenExps s (k+1) nvs++	-- | Create a single generator.+	mkGenExp :: SrcLoc -> MFunMetaInfo -> (HsStmt, HsName)+	mkGenExp s nvt = let [(g, (name, _t))] = mkGenExps s 0 [nvt]+			  in (g, name)++	-- | Generate a single generator with a call to (ng)manyMatch,+	-- and an extra variable name to use after unzipping. +	mkManyGen :: SrcLoc -> Bool -> HsName -> HsStmt+	mkManyGen s greedy mname =+		-- Choose which repeater function to use, determined by greed+		let mf  = if greedy then gManyMatchFun else manyMatchFun+		 -- ... and create a generator that applies it to the+		 -- matching function in question.+		 in genStmt s (pvar valsvarsname) $ +		 	app mf (var mname)++	-- | Generate declarations for @: and @ bindings.+	asDecl :: (HsExp -> HsExp) -> SrcLoc -> MFunMetaInfo -> Tr HsName+	asDecl mf s nvt@(_, vs, _) = do+		-- A name, if you would+		n <- genMatchName					 -- harp_matchX+		let -- Generate a generator for matching the subpattern+		    (g, val) = mkGenExp s nvt				 -- (harp_valY, (foo, ...)) <- harp_matchZ+		    -- ... fix the old variables+		    vars     = map var vs				 -- (apa, bepa, ...)+		    -- ... and return the generated value, along with the+		    -- new set of variables which is the old set prepended+		    -- by the variable currently being bound.+		    ret = qualStmt $ metaReturn $ tuple			 -- return (harp_valY, ($mf harp_valY, apa, ...))+				[var val, tuple $ mf (var val) : vars] 	 -- mf in the line above is what separates+									 -- @: ((:)) from @ (const)+		-- Finally we create a declaration for this function and +		-- add it to the store.+		pushDecl $ nameBind s n $ doE [g, ret]			 -- harp_matchX = do ...+		return n++  	-- | Generate declarations for optional patterns, ? and #?.+  	-- (Unfortunally we must place this function here since both variations+  	-- of transformations of optional patterns should be able to call it...)+  	mkOptDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+  	mkOptDecl s greedy nvt@(_, vs, t) = do+  		-- Un nome, s'il vouz plaît.+  		n <- genMatchName+  		let -- Generate a generator for matching the subpattern+  		    (g, val) = mkGenExp s nvt			-- (harp_valX, (foo, bar, ...)) <- harp_matchY+  		    -- ... and apply a Just to its value+  		    ret1 = metaReturn $ tuple 			-- return (Just harp_val1, (foo, bar, ...))+  				[app (var just_name) +  				 (var val), varTuple vs]+  		    -- ... and do those two steps in a do-expression+  		    exp1 = doE [g, qualStmt ret1]		-- do ....+  		    -- For the non-matching branch, all the variables should be empty+  		    ids  = map (const idFun) vs			-- (id, id, ...)+  		    -- ... and the value should be Nothing.+  		    ret2 = metaReturn $ tuple			-- return (Nothing, (id, id, ...))+  		    		[var nothing_name, tuple ids]	-- i.e. no vars were bound+  		    -- The order of the arguments to the choice (+++) operator +  		    -- is determined by greed...+  		    mc   = if greedy +  		    	    then metaChoice 	   -- standard order+  		    	    else (flip metaChoice) -- reversed order+  		    -- ... and then apply it to the branches.+  		    rhs  = (paren exp1) `mc` 			-- (do ....) +++ +  		    		(paren ret2)			--  (return (Nothing, .....))+  		-- Finally we create a declaration for this function and+  		-- add it to the store.+  		pushDecl $ nameBind s n rhs			-- harp_matchZ = (do ....) +++ (return ....)+  		-- The type of the returned value will be Maybe the type+  		-- of the value of the subpattern.+  		return (n, vs, M t)+ +  	-- | Generate declarations for star patterns, * and #*+  	-- (Unfortunally we must place this function here since both variations+  	-- of transformations of repeating patterns should be able to call it...)+  	mkStarDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+  	mkStarDecl s greedy (mname, vs, t) = do+  		-- Ett namn, tack!+  		n <- genMatchName+  		let -- Create a generator that matches the subpattern+  		    -- many times, either greedily or non-greedily+  		    g = mkManyGen s greedy mname+  		    -- ... and unzip the result, choosing the proper unzip+  		    -- function depending on the number of variables returned.+  		    metaUnzipK = mkMetaUnzip s (length vs)+  		    -- ... first unzip values from variables+  		    dec1    = patBind s (pvarTuple [valname, varsname])+  		    		(metaUnzip $ var valsvarsname)+  		    -- ... and then unzip the variables+  		    dec2    = patBind s (pvarTuple vs)+  		    		(metaUnzipK $ var varsname)+  		    -- ... fold all the values for variables+  		    retExps = map ((app foldCompFun) . var) vs+  		    -- ... and return value and variables+  		    ret     = metaReturn $ tuple $+  		    		[var valname, tuple retExps]+  		-- Finally we need to generate a function that does all this,+  		-- using a let-statement for the non-monadic stuff and a+  		-- do-expression to wrap it all in.+  		pushDecl $ nameBind s n $+  		  doE [g, letStmt [dec1, dec2], qualStmt ret]+  		-- The type of the returned value is a list ([]) of the+  		-- type of the subpattern.+  		return (n, vs, L t)+  		+  	-- | Generate declarations for plus patterns, + and #++  	-- (Unfortunally we must place this function here since both variations+  	-- of transformations of non-empty repeating patterns should be able to call it...)+  	mkPlusDecl :: SrcLoc -> Bool -> MFunMetaInfo -> Tr MFunMetaInfo+  	mkPlusDecl s greedy nvt@(mname, vs, t) = do+  		-- and now I've run out of languages...+  		n <- genMatchName+  		let k = length vs+  		    -- First we want a generator to match the+  		    -- subpattern exactly one time+  		    (g1, val1) = mkGenExp s nvt			-- (harp_valX, (foo, ...)) <- harpMatchY+  		    -- ... and then one that matches it many times.+  		    g2         = mkManyGen s greedy mname	-- harp_vvs <- manyMatch harpMatchY+  		    -- ... we want to unzip the result, using+  		    -- the proper unzip function+  		    metaUnzipK = mkMetaUnzip s k+  		    -- ... first unzip values from variables+  		    dec1    = patBind s 			-- (harp_vals, harp_vars) = unzip harp_vvs+  		    		(pvarTuple [valsname, varsname])+  		    		(metaUnzip $ var valsvarsname)+  		    -- .. now we need new fresh names for variables+  		    -- since the ordinary ones are already taken.+  		    vlvars  = genNames "harp_vl" k+  		    -- ... and then we can unzip the variables+  		    dec2    = patBind s (pvarTuple vlvars)	-- (harp_vl1, ...) = unzipK harp_vars+  		    		(metaUnzipK $ var varsname)+  		    -- .. and do the unzipping in a let-statement+		    letSt   = letStmt [dec1, dec2]+  		    -- ... fold variables from the many-match,+  		    -- prepending the variables from the single match+  		    retExps = map mkRetFormat $ zip vs vlvars	-- foo . (foldComp harp_vl1), ...+  		    -- ... prepend values from the single match to+  		    -- those of the many-match.+  		    retVal  = (var val1) `metaCons` +  		    		(var valsname)			-- harp_valX : harp_vals+  		    -- ... return all values and variables+  		    ret     = metaReturn $ tuple $		-- return (harp_valX:harpVals, +  		    		[retVal, tuple retExps]		--   (foo . (...), ...))+  		    -- ... and wrap all of it in a do-expression.+		    rhs     = doE [g1, g2, letSt, qualStmt ret]+  		-- Finally we create a declaration for this function and+  		-- add it to the store.+		pushDecl $ nameBind s n rhs+  		-- The type of the returned value is a list ([]) of the+  		-- type of the subpattern.+		return (n, vs, L t)++	  where mkRetFormat :: (HsName, HsName) -> HsExp+	  	mkRetFormat (v, vl) =+	  		-- Prepend variables using function composition.+	  		(var v) `metaComp`+	  		  (paren $ (app foldCompFun) $ var vl)+++--------------------------------------------------------------------------+-- HaRP-specific functions and ids++-- | Functions and ids from the @Match@ module, +-- used in the generated matching functions+runMatchFun, baseMatchFun, manyMatchFun, gManyMatchFun :: HsExp+runMatchFun = match_qual runMatch_name+baseMatchFun = match_qual baseMatch_name+manyMatchFun = match_qual manyMatch_name+gManyMatchFun = match_qual gManyMatch_name++runMatch_name, baseMatch_name, manyMatch_name, gManyMatch_name :: HsName+runMatch_name = HsIdent "runMatch"+baseMatch_name = HsIdent "baseMatch"+manyMatch_name = HsIdent "manyMatch"+gManyMatch_name = HsIdent "gManyMatch"++match_mod, match_qual_mod :: Module+match_mod = Module "Harp.Match"+match_qual_mod = Module "HaRPMatch"++functor_qual_mod = Module "FunctorSugar"++sugarFun = qvar functor_qual_mod $ HsIdent "functorSugar"+callFun = qvar functor_qual_mod $ HsIdent "functorCall"++match_qual :: HsName -> HsExp+match_qual = qvar match_qual_mod++choiceOp :: HsQOp+choiceOp = HsQVarOp $ Qual match_qual_mod choice++appendOp :: HsQOp+appendOp = HsQVarOp $ UnQual append++-- foldComp = foldl (.) id, i.e. fold by composing+foldCompFun :: HsExp+foldCompFun = match_qual $ HsIdent "foldComp"++mkMetaUnzip :: SrcLoc -> Int -> HsExp -> HsExp+mkMetaUnzip s k | k <= 7 = let n = "unzip" ++ show k+	      		    in (\e -> matchFunction n [e])+	        | otherwise = +		   let vs      = genNames "x" k+	      	       lvs     = genNames "xs" k+		       uz      = name $ "unzip" ++ show k+		       ys      = name "ys"+		       xs      = name "xs"+		       alt1    = alt s peList $ tuple $ replicate k eList	-- [] -> ([], [], ...)+		       pat2    = (pvarTuple vs) `metaPCons` (pvar xs)		-- (x1, x2, ...)+		       ret2    = tuple $ map appCons $ zip vs lvs		-- (x1:xs1, x2:xs2, ...)+		       rhs2    = app (var uz) (var xs)				-- unzipK xs+		       dec2    = patBind s (pvarTuple lvs) rhs2			-- (xs1, xs2, ...) = unzipK xs+		       exp2    = letE [dec2] ret2+		       alt2    = alt s pat2 exp2+		       topexp  = lamE s [pvar ys] $ caseE (var ys) [alt1, alt2]+		       topbind = nameBind s uz topexp+		    in app (paren $ letE [topbind] (var uz))+  where appCons :: (HsName, HsName) -> HsExp+  	appCons (x, xs) = metaCons (var x) (var xs)++matchFunction :: String -> [HsExp] -> HsExp+matchFunction s es = mf s (reverse es)+  where mf s []     = match_qual $ HsIdent s+  	mf s (e:es) = app (mf s es) e++-- | Some 'magic' gensym-like functions, and functions+-- with related functionality.+retname :: HsName+retname = name "harp_ret"++varsname :: HsName+varsname = name "harp_vars"++valname :: HsName+valname = name "harp_val"++valsname :: HsName+valsname = name "harp_vals"++valsvarsname :: HsName+valsvarsname = name "harp_vvs"++mkValName :: Int -> HsName+mkValName k = name $ "harp_val" ++ show k++extendVar :: HsName -> String -> HsName+extendVar (HsIdent n) s = HsIdent $ n ++ s+extendVar n _ = n++xNameParts :: HsXName -> (Maybe String, String)+xNameParts n = case n of+		HsXName s      -> (Nothing, s)+		HsXDomName d s -> (Just d, s)++---------------------------------------------------------+-- meta-level functions, i.e. functions that represent functions, +-- and that take arguments representing arguments... whew!++metaReturn, metaConst, metaMap, metaUnzip :: HsExp -> HsExp+metaReturn e = metaFunction "return" [e]+metaConst e  = metaFunction "const" [e]+metaMap e    = metaFunction "map" [e]+metaUnzip e  = metaFunction "unzip" [e]++metaEither, metaMaybe :: HsExp -> HsExp -> HsExp+metaEither e1 e2 = metaFunction "either" [e1,e2]+metaMaybe e1 e2 = metaFunction "maybe" [e1,e2]++metaConcat :: [HsExp] -> HsExp+metaConcat es = metaFunction "concat" [listE es]++metaAppend :: HsExp -> HsExp -> HsExp+metaAppend l1 l2 = infixApp l1 appendOp l2++-- the +++ choice operator+metaChoice :: HsExp -> HsExp -> HsExp+metaChoice e1 e2 = infixApp e1 choiceOp e2++metaPCons :: HsPat -> HsPat -> HsPat+metaPCons p1 p2 = HsPInfixApp p1 cons p2++metaCons, metaComp :: HsExp -> HsExp -> HsExp+metaCons e1 e2 = infixApp e1 (HsQConOp cons) e2+metaComp e1 e2 = infixApp e1 (op fcomp) e2++metaPJust :: HsPat -> HsPat+metaPJust p = pApp just_name [p]++metaPNothing :: HsPat+metaPNothing = pvar nothing_name++metaPMkMaybe :: Maybe HsPat -> HsPat+metaPMkMaybe mp = case mp of+	Nothing -> metaPNothing+	Just p  -> pParen $ metaPJust p++metaJust :: HsExp -> HsExp+metaJust e = app (var just_name) e++metaNothing :: HsExp+metaNothing = var nothing_name++metaMkMaybe :: Maybe HsExp -> HsExp+metaMkMaybe me = case me of+	Nothing -> metaNothing+	Just e  -> paren $ metaJust e++---------------------------------------------------+-- some other useful functions at abstract level+consFun, idFun :: HsExp+consFun = HsCon cons+idFun = function "id"++cons :: HsQName+cons = Special HsCons++fcomp, choice, append :: HsName+fcomp = HsSymbol "."+choice = HsSymbol "+++"+append = HsSymbol "++"++just_name, nothing_name, left_name, right_name :: HsName+just_name = HsIdent "Just"+nothing_name = HsIdent "Nothing"+left_name = HsIdent "Left"+right_name = HsIdent "Right"++------------------------------------------------------------------------+-- Help functions for meta programming xml++hsx_data_mod :: Module+hsx_data_mod = Module "HSP.Data"++-- | Create an xml PCDATA value+metaMkPcdata :: String -> HsExp+metaMkPcdata s = metaFunction "pcdata" [strE s]++-- | Create an xml tag, given its domain, name, attributes and+-- children.+metaMkTag :: HsXName -> [HsExp] -> Maybe HsExp -> [HsExp] -> HsExp+metaMkTag name ats mat cs = +	let (d,n) = xNameParts name+	    ne    = tuple [metaMkMaybe $ fmap strE d, strE n]+	    m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaToAttribute x)) mat+	    attrs = m $ listE $ map metaToAttribute ats+	 in metaFunction "genTag" [ne, attrs, listE cs]++-- | Create an empty xml tag, given its domain, name and attributes.+metaMkETag :: HsXName -> [HsExp] -> Maybe HsExp -> HsExp+metaMkETag name ats mat = +	let (d,n) = xNameParts name+	    ne    = tuple [metaMkMaybe $ fmap strE d, strE n]+	    m = maybe id (\x y -> paren $ y `metaAppend` (metaMap $ metaToAttribute x)) mat+	    attrs = m $ listE $ map metaToAttribute ats+	 in metaFunction "genETag" [ne, attrs]++-- | Create an attribute by applying the overloaded @toAttribute@+metaToAttribute :: HsExp -> HsExp+metaToAttribute e = metaFunction "toAttribute" [e]++-- | Create a property from an attribute and a value.+metaAssign :: HsExp -> HsExp -> HsExp+metaAssign e1 e2 = infixApp e1 assignOp e2+  where assignOp = HsQVarOp $ UnQual $ HsSymbol ":="++-- | Make xml out of some expression by applying the overloaded function+-- @toXml@.+metaToXmls :: HsExp -> HsExp+metaToXmls e = metaFunction "toXMLs" [paren e]++-- | Lookup an attribute in the set of attributes.+metaExtract :: HsXName -> HsName -> HsExp+metaExtract name attrs = +	let (d,n) = xNameParts name+	    np    = tuple [metaMkMaybe $ fmap strE d, strE n]+	 in metaFunction "extract" [np, var attrs]++-- | Generate a pattern under the Tag data constructor.+metaTag :: (Maybe String) -> String -> HsPat -> HsPat -> HsPat+metaTag dom name ats cpat =+	let d = metaPMkMaybe $ fmap strP dom+	    n = pTuple [d, strP name]+	 in metaConPat "Tag" [n, ats, cpat]+	 +-- | Generate a pattern under the PCDATA data constructor.+metaPcdata :: String -> HsPat+metaPcdata s = metaConPat "PCDATA" [strP s]++metaMkName :: HsXName -> HsExp+metaMkName n = case n of+	HsXName s      -> strE s+	HsXDomName d s -> tuple [strE d, strE s]
+ _darcs/pristine/Preprocessor/Main.hs view
@@ -0,0 +1,56 @@+module Main where++import Preprocessor.Hsx++import System.Environment (getArgs)+import Data.List (intersperse, isPrefixOf)++checkParse p = case p of+		  ParseOk m -> m+		  ParseFailed loc s -> error $ "Error at " ++ show loc ++ ":\n" ++ s++transformFile :: String -> String -> String -> IO ()+transformFile origfile infile outfile = do+	f <- readFile infile+	let fm = process origfile f+	writeFile outfile fm++testFile :: String -> IO ()+testFile file = do+	f <- readFile file+	putStrLn $ process file f+++testTransform :: String -> IO ()+testTransform file = do+	f <- readFile file+	putStrLn $ show $ transform $ checkParse $ parse file f+	+testPretty :: String -> IO ()+testPretty file = do+	f <- readFile file+	putStrLn $ prettyPrint $ checkParse $ parse file f++testParse :: String -> IO ()+testParse file = do+	f <- readFile file+	putStrLn $ show $ parse file f++main :: IO ()+main = do args <- getArgs+	  case args of+	   [origfile, infile, outfile] -> transformFile origfile infile outfile+	   [infile, outfile] -> transformFile infile infile outfile+	   [infile] -> testFile infile+	   _ -> putStrLn usageString+++process :: FilePath -> String -> String+process fp fc = prettyPrintWithMode (defaultMode {linePragmas=True}) $ +                 transform $ checkParse $ parse fp fc++parse fn fc = parseModuleWithMode (ParseMode fn) fcuc+  where fcuc= unlines $ filter (not . isPrefixOf "#") $ lines fc+++usageString = "Usage: trhsx <infile> [<outfile>]"
+ _darcs/pristine/RDF.hs view
@@ -0,0 +1,135 @@+module RDF where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Cache+import Utils++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Set (Set)+import qualified Data.Set as Set++data Node = URI String | PlainLiteral String    deriving (Eq, Ord)+data Dir  = Pos | Neg                           deriving (Eq, Ord, Show)++instance Show Node where+    show (URI uri)        = showURI [("rdfs", rdfs)] uri+    show (PlainLiteral s) = "\"" ++ s ++ "\""++type Triple = (Node, Node, Node)+type Side   = Map Node (Map Node (Set Node))+data Graph  = Graph Side Side (Set Triple) deriving (Show, Eq)++instance Hashable Node where+    hash (URI s) = hash s+    hash (PlainLiteral s) = hash s+    +instance Hashable Dir where+    hash Pos = 0+    hash Neg = 1++rdfs         =     "http://www.w3.org/2000/01/rdf-schema#"+rdfs_label   = URI "http://www.w3.org/2000/01/rdf-schema#label"+rdfs_seeAlso = URI "http://www.w3.org/2000/01/rdf-schema#seeAlso"++showURI ((short, long):xs) uri | take (length long) uri == long =+                                     short ++ ":" ++ drop (length long) uri+                               | otherwise = showURI xs uri+showURI [] uri = "<" ++ uri ++ ">"++subject :: Triple -> Node+subject (s,_,_) = s++predicate :: Triple -> Node+predicate (_,p,_) = p++object :: Triple -> Node+object (_,_,o) = o++graphSide :: Dir -> Graph -> Side+graphSide Neg (Graph s _ _) = s+graphSide Pos (Graph _ s _) = s++hasConn :: Graph -> Node -> Node -> Dir -> Bool+hasConn g node prop dir = isJust $ do m <- Map.lookup node (graphSide dir g)+                                      Map.lookup prop m++getOne :: Graph -> Node -> Node -> Dir -> Maybe Node+getOne g node prop dir = if null nodes then Nothing else Just $ head nodes+    where nodes = Set.toList (getAll g node prop dir)+    +getAll :: Graph -> Node -> Node -> Dir -> Set Node+getAll g node prop dir = +    Map.findWithDefault Set.empty prop $ getConns g node dir++getConns :: Graph -> Node -> Dir -> Map Node (Set Node)+getConns g node dir = Map.findWithDefault Map.empty node $ graphSide dir g++emptyGraph :: Graph+emptyGraph = Graph (Map.empty) (Map.empty) Set.empty++listToGraph :: [Triple] -> Graph+listToGraph = foldr insert emptyGraph++graphToList :: Graph -> [Triple]+graphToList (Graph _ _ triples) = Set.toAscList triples++mergeGraphs :: Op Graph+mergeGraphs g1 g2 = foldr insertVirtual g1 (graphToList g2)++insert :: Triple -> Graph -> Graph+insert t (Graph neg pos triples) =+    insertVirtual t (Graph neg pos $ Set.insert t triples)++insertVirtual :: Triple -> Graph -> Graph+insertVirtual (s,p,o) (Graph neg pos triples) =+    Graph (ins o p s neg) (ins s p o pos) triples where+    ins a b c = Map.alter (Just . Map.alter (Just . Set.insert c . fromMaybe Set.empty) b . fromMaybe Map.empty) a   -- Gack!!! Need to make more readable+    +delete :: Triple -> Graph -> Graph+delete (s,p,o) (Graph neg pos triples) = +    Graph (del o p s neg) (del s p o pos) $ Set.delete (s,p,o) triples where+    del a b c = Map.adjust (Map.adjust (Set.delete c) b) a+    +deleteAll :: Node -> Node -> Graph -> Graph+deleteAll s p g = dels s p os g where+    dels s' p' (o':os') g' = dels s' p' os' (delete (s',p',o') g')+    dels _  _  []       g' = g'+    os = Set.toList $ getAll g s p Pos+    +update :: Triple -> Graph -> Graph+update (s,p,o) g = insert (s,p,o) $ deleteAll s p g+    +triple :: Dir -> (Node,Node,Node) -> Triple+triple Pos (s,p,o) = (s,p,o)+triple Neg (o,p,s) = (s,p,o)++fromNode :: Node -> String+fromNode (URI uri)        = uri+fromNode (PlainLiteral s) = s++rev :: Dir -> Dir+rev Pos = Neg+rev Neg = Pos++mul :: Num a => Dir -> a -> a+mul Pos = id+mul Neg = negate
+ _darcs/pristine/README view
@@ -0,0 +1,81 @@+===================+Fenfire version 0.1+===================+++Introduction+============++Fenfire is a graph-based notetaking system. (We're planning to add a+kitchen sink soon.) It is developed on the channel #fenfire on the+Freenode IRC network.+++The source code is available using Darcs.+    darcs get http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs+++Requirements for compilation+============================++Fenfire source code++Dependencies with known-to-work version numbers:++  ghc    6.6    (The Glorious Glasgow Haskell Compilation System)+  gtk2hs 0.9.11 (A GUI library for Haskell based on Gtk, release candidate ok)+  raptor 1.4.9  (Raptor RDF Parser Toolkit)+  c2hs   0.14.5 (C->Haskell, An Interface Generator for Haskell)+  harp   0.2    (Haskell Regular Patterns, in haskell-src-exts)+  haxml  1.13.2 (Haskell and XML)+  happy  1.15   (The Parser Generator for Haskell)+  alex   2.0.1  (A lexical analyser generator for Haskell)++(Packages in Debian: ghc6 libghc6-gtk-dev libraptor1-dev c2hs libghc6-harp-dev + libghc6-haxml-dev happy alex)+++Running a precompiled binary only requires:+gmp             (The GNU MP Bignum Library)+gtk             (The GIMP Toolkit)+raptor          (Raptor RDF Parser Toolkit)++(Packages in Debian: libgmp3c2 libgtk2.0-0 libraptor1)+++Compiling and running+=====================++Fenfire-hs is packaged using the Haskell Cabal, which means you can use the +following commands to configure, build, and install it to your home directory:++runhaskell Setup.hs configure --user --prefix ~+runhaskell Setup.hs build+runhaskell Setup.hs install++After this, you can start the application like this:++~/bin/fenfire++You will see the application launch with a new graph where you can+start adding your notes using the Edit menu and the included key bindings.++* The current node is highlighted in blue.++* To write into the current node, move to the text box at the bottom+  of the window using Tab or the mouse. After you've finished typing,+  use Tab or the mouse to get back to the graph box.++* Use the Edit menu or the keybindings indicated in the Edit menu to+  - create new nodes+  - mark the current node, or connect the current node to the+    previously marked node(s)+  - break connections between nodes++* Use the arrow keys to move between nodes:+  - Left and Right move to the node directly left or directly right+    from the current node.+  - Up and Down scroll through the nodes connected to the current node.+  - Instead of Left/Right/Up/Down, you can also use j/l/i/comma.++You cannot currently use the mouse to move around the structure.
+ _darcs/pristine/Raptor.chs view
@@ -0,0 +1,222 @@+-- We want the C compiler to always check that types match:+{-# OPTIONS_GHC -fvia-C #-}+module Raptor where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Foreign (Ptr, FunPtr, Storable(pokeByteOff, peekByteOff), allocaBytes,+                nullPtr, castPtr, freeHaskellFunPtr)+import Foreign.C (CString, castCharToCChar, withCString, peekCString, CFile,+                  CSize, CInt, CUChar, CChar)++import System.Posix.IO (stdOutput)+import System.Posix.Types (Fd)+import System.Environment (getArgs)++import Control.Monad (when)+import Data.IORef (modifyIORef, readIORef, newIORef)+import Control.Exception (bracket)++#include <raptor.h>++-- the following three helpers are copied from C2HS.hs:+cToEnum :: (Integral i, Enum e) => i -> e+cToEnum  = toEnum . cIntConv++cFromEnum :: (Enum e, Integral i) => e -> i+cFromEnum  = cIntConv . fromEnum++cIntConv :: (Integral a, Integral b) => a -> b+cIntConv  = fromIntegral+++{#context lib="raptor" prefix="raptor"#}++{#enum raptor_identifier_type as IdType {} deriving (Show)#}++{#enum raptor_uri_source as UriSource {} deriving (Show)#}++{#pointer raptor_uri as URI newtype#}++{#pointer *statement as Statement newtype#}++unStatement :: Statement -> Ptr Statement+unStatement (Statement ptr) = ptr++{#pointer *parser as Parser newtype#}++{#pointer *serializer as Serializer newtype#}++unSerializer :: Serializer -> Ptr Serializer+unSerializer (Serializer ptr) = ptr++type Triple = (Identifier, Identifier, Identifier)++data Identifier = Uri String | Blank String | Literal String+                  deriving (Show)++mkIdentifier :: IO (Ptr ()) -> IO CInt -> IO Identifier+mkIdentifier value format = do+  value' <- value+  format' <- format+  f (castPtr value') (cToEnum format')+    where f v IDENTIFIER_TYPE_RESOURCE = do+                              cstr <- {#call uri_as_string#} (castPtr v) +                              str <- peekCString (castPtr cstr) +                              return $ Uri str+          f v IDENTIFIER_TYPE_PREDICATE = f v IDENTIFIER_TYPE_RESOURCE+          f v IDENTIFIER_TYPE_LITERAL = peekCString v >>= return . Literal+          f v IDENTIFIER_TYPE_ANONYMOUS = peekCString v >>= return . Blank+          f _ i = error $ "Raptor.mkIdentifier: Deprecated type: " ++ show i++getSubject :: Statement -> IO Identifier+getSubject (Statement s) = mkIdentifier ({#get statement->subject#} s)+                                        ({#get statement->subject_type#} s)++getPredicate :: Statement -> IO Identifier+getPredicate (Statement s) = mkIdentifier ({#get statement->predicate#} s)+                                          ({#get statement->predicate_type#} s)++getObject :: Statement -> IO Identifier+getObject (Statement s) = mkIdentifier ({#get statement->object#} s)+                                       ({#get statement->object_type#} s)++withURI :: String -> (Ptr URI -> IO a) -> IO a+withURI string = bracket (withCString string $ {# call new_uri #} . castPtr)+                         {# call free_uri #}++withIdentifier :: (Ptr Statement -> Ptr () -> IO ()) ->+                  (Ptr Statement -> CInt -> IO ()) -> +                  Statement -> Identifier -> IO a -> IO a+withIdentifier setValue setFormat (Statement t) (Uri s) io = do +    setFormat t (cFromEnum IDENTIFIER_TYPE_RESOURCE)+    withURI s $ \uri -> do+        setValue t (castPtr uri)+        io+withIdentifier setValue setFormat (Statement t) (Literal s) io = do+    setFormat t (cFromEnum IDENTIFIER_TYPE_LITERAL)+    withCString s $ \str -> do+        setValue t (castPtr str)+        io+withIdentifier _ _ _ i _ =+    error $ "Raptor.setIdentifier: unimplemented: " ++ show i++withSubject = withIdentifier {# set statement->subject #}+                             {# set statement->subject_type #} ++withPredicate = withIdentifier {# set statement->predicate #}+                               {# set statement->predicate_type #}++withObject = withIdentifier {# set statement->object #}+                            {# set statement->object_type #}++type Handler a = Ptr a -> Statement -> IO ()+foreign import ccall "wrapper"+   mkHandler :: (Handler a) -> IO (FunPtr (Handler a))++foreign import ccall "raptor.h raptor_init" initRaptor :: IO ()+foreign import ccall "raptor.h raptor_new_parser" new_parser :: Ptr CChar -> IO (Ptr Parser)+foreign import ccall "raptor.h raptor_set_statement_handler" set_statement_handler :: Ptr Parser -> Ptr a -> FunPtr (Handler a) -> IO () +foreign import ccall "raptor.h raptor_uri_filename_to_uri_string" uri_filename_to_uri_string :: CString -> IO CString+foreign import ccall "raptor.h raptor_new_uri" new_uri :: Ptr CChar -> IO (Ptr URI)+foreign import ccall "raptor.h raptor_uri_copy" uri_copy :: Ptr URI -> IO (Ptr URI)+foreign import ccall "raptor.h raptor_parse_file" parse_file :: Ptr Parser -> Ptr URI -> Ptr URI -> IO ()++foreign import ccall "raptor.h raptor_print_statement_as_ntriples" print_statement_as_ntriples :: Statement -> Ptr CFile -> IO ()++foreign import ccall "stdio.h fdopen" fdopen :: Fd -> CString -> IO (Ptr CFile)+foreign import ccall "stdio.h fputc" fputc :: CChar -> Ptr CFile -> IO ()++foreign import ccall "string.h memset" c_memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)+++-- | Serialize the given triples into a file with the given filename+--+triplesToFilename :: [Triple] -> String -> IO ()+triplesToFilename triples filename = do +  initRaptor++  serializer <- withCString "ntriples" {# call new_serializer #}+  when (unSerializer serializer == nullPtr) $ fail "serializer is null"+  +  withCString filename $ {# call serialize_start_to_filename #} serializer++  allocaBytes {# sizeof statement #} $ \ptr -> do+    let t = Statement ptr+    flip mapM_ triples $ \(s,p,o) -> do+      c_memset ptr 0 {# sizeof statement #}+      withSubject t s $ withPredicate t p $ withObject t o $ do+        {# call serialize_statement #} serializer t+        return ()+  {# call serialize_end #} serializer+  {# call free_serializer #} serializer+  {# call finish #}++-- | Parse a file with the given filename into triples+--+filenameToTriples :: String -> IO [Triple]+filenameToTriples filename = do +  result <- newIORef []++  initRaptor+  let suffix = reverse $ takeWhile (/= '.') $ reverse filename+      parsertype = case suffix of "turtle" -> "turtle"+                                  _        -> "guess"+  rdf_parser <- withCString parsertype new_parser +  when (rdf_parser == nullPtr) $ fail "parser is null"+  handler <- mkHandler $ \_user_data triple -> do+    s <- getSubject triple+    p <- getPredicate triple+    o <- getObject triple+    modifyIORef result ((s,p,o):)++  set_statement_handler rdf_parser nullPtr handler+  uri_str <- withCString filename uri_filename_to_uri_string+  uri <- new_uri uri_str+  base_uri <- uri_copy uri+  parse_file rdf_parser uri base_uri++  {# call free_parser #} (Parser rdf_parser)+  freeHaskellFunPtr handler+  {# call free_uri #} uri+  {# call free_uri #} base_uri+  {# call free_memory #} (castPtr uri_str)++  {# call finish #}+  readIORef result++-- The following print_triple and filenameToStdout are an incomplete and +-- improved translation of raptor examples/rdfprint.c:++print_triple :: Ptr CFile -> Handler a+print_triple outfile _user_data s = do print_statement_as_ntriples s outfile+                                       fputc (castCharToCChar '\n') outfile++filenameToStdout :: String -> IO ()+filenameToStdout filename = do+  outfile <- withCString "w" $ fdopen stdOutput++  initRaptor+  rdf_parser <- withCString "guess" new_parser +  when (rdf_parser == nullPtr) $ fail "parser is null"+  mkHandler (print_triple outfile) >>= set_statement_handler rdf_parser nullPtr+  uri <- withCString filename uri_filename_to_uri_string >>= new_uri+  base_uri <- uri_copy uri+  parse_file rdf_parser uri base_uri+  return ()
+ _darcs/pristine/Setup.hs view
@@ -0,0 +1,43 @@+#!/usr/bin/env runhaskell+import Control.Monad (when)+import Distribution.PreProcess+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils (rawSystemVerbose, dieWithLocation)+import System.Cmd (system)+import System.Directory (getModificationTime, doesFileExist)++main = defaultMainWithHooks hooks+hooks = defaultUserHooks { hookedPreProcessors = [trhsx, c2hs] }++trhsx :: PPSuffixHandler+trhsx = ("fhs", f) where+    f buildInfo localBuildInfo inFile outFile verbose = do+        when (verbose > 3) $+            putStrLn ("checking that preprocessor is up-to-date")+        let [pIn, pOut] = ["Preprocessor/Hsx/Parser."++s | s <- ["ly","hs"]]+        exists <- doesFileExist pOut+        runHappy <- if not exists then return True else do+            [tIn, tOut] <- mapM getModificationTime [pIn, pOut]+            return (tIn > tOut)+        when runHappy $ system ("happy "++pIn) >> return ()+        system ("ghc --make Preprocessor/Main.hs -o preprocessor")++        when (verbose > 0) $+            putStrLn ("preprocessing "++inFile++" to "++outFile)+        writeFile outFile ("-- GENERATED file. Edit the ORIGINAL "++inFile+++                           " instead.\n")+        system ("./preprocessor "++inFile++" >> "++outFile)+        +c2hs :: PPSuffixHandler+c2hs = ("chs", f) where+    f buildInfo localBuildInfo inFile outFile verbose = do+        when (verbose > 0) $+            putStrLn $ "preprocess "++inFile++" to "++outFile+        maybe (dieWithLocation inFile Nothing "no c2hs available")+              (\c2hs -> rawSystemVerbose verbose c2hs+                            ["--cppopts", "-D\"__attribute__(A)= \"", +                             "-o", outFile, inFile])+              (withC2hs localBuildInfo) +            +                         
+ _darcs/pristine/Utils.hs view
@@ -0,0 +1,163 @@+-- For (instance MonadReader w m => MonadReader w (MaybeT m)) in GHC 6.6:+{-# OPTIONS_GHC -fallow-undecidable-instances #-}+module Utils where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Control.Applicative+import Control.Monad+import Control.Monad.List+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans+import Control.Monad.Writer (WriterT(..), MonadWriter(..), execWriterT)++import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))++import qualified System.Time+++-- just what the rhs says, a function from a type to itself+type Endo a = a -> a++type EndoM m a = a -> m a+type Op a      = a -> a -> a++type Time     = Double -- seconds since the epoch+type TimeDiff = Double -- in seconds+++avg :: Fractional a => Op a+avg x y = (x+y)/2+++maybeReturn :: MonadPlus m => Maybe a -> m a+maybeReturn = maybe mzero return++returnEach :: MonadPlus m => [a] -> m a+returnEach = msum . map return++maybeDo :: Monad m => Maybe a -> (a -> m ()) -> m ()+maybeDo m f = maybe (return ()) f m+++getTime :: IO Time+getTime = do (System.Time.TOD secs picosecs) <- System.Time.getClockTime+             return $ fromInteger secs + fromInteger picosecs / (10**(3*4))+             +             +(&) :: Monoid m => m -> m -> m+(&) = mappend+++funzip :: Functor f => f (a,b) -> (f a, f b)+funzip x = (fmap fst x, fmap snd x)++ffor :: Functor f => f a -> (a -> b) -> f b+ffor = flip fmap++forM_ :: Monad m => [a] -> (a -> m b) -> m ()+forM_ = flip mapM_++forA2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c+forA2 x y f = liftA2 f x y++forA3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d+forA3 a b c f = liftA3 f a b c+++newtype Comp f g a = Comp { fromComp :: f (g a) }++instance (Functor f, Functor g) => Functor (Comp f g) where+    fmap f (Comp m) = Comp (fmap (fmap f) m)+    +instance (Applicative f, Applicative g) => Applicative (Comp f g) where+    pure = Comp . pure . pure+    Comp f <*> Comp x = Comp $ forA2 f x (<*>)+++newtype BreadthT m a = BreadthT { runBreadthT :: WriterT [BreadthT m ()] m a }+    +scheduleBreadthT :: Monad m => BreadthT m a -> BreadthT m ()+scheduleBreadthT m = BreadthT $ tell [m >> return ()]++execBreadthT :: Monad m => BreadthT m a -> m ()+execBreadthT m = do rest <- execWriterT (runBreadthT m)+                    when (not $ null rest) $ execBreadthT (sequence_ rest)++instance Monad m => Monad (BreadthT m) where+    return  = BreadthT . return+    m >>= f = BreadthT (runBreadthT m >>= runBreadthT . f)+    +instance MonadTrans BreadthT where+    lift = BreadthT . lift+    +instance MonadState s m => MonadState s (BreadthT m) where+    get = lift $ get+    put = lift . put+    +instance MonadWriter w m => MonadWriter w (BreadthT m) where+    tell = lift . tell+    listen m = BreadthT $ WriterT $ do+        ((x,w),w') <- listen $ runWriterT (runBreadthT m)+        return ((x,w'),w)+    pass m = BreadthT $ WriterT $ pass $ do+        ((x,f),w) <- runWriterT (runBreadthT m)+        return ((x,w),f)+++newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }++instance Monad m => Monad (MaybeT m) where+    return x = MaybeT $ return (Just x)+    m >>= f  = MaybeT $ do x <- runMaybeT m+                           maybe (return Nothing) (runMaybeT . f) x+    fail _   = mzero+    +instance MonadTrans MaybeT where+    lift m = MaybeT $ do x <- m; return (Just x)++instance Monad m => MonadPlus (MaybeT m) where+    mzero = MaybeT $ return Nothing+    mplus m n = MaybeT $ do+        x <- runMaybeT m; maybe (runMaybeT n) (return . Just) x+        +instance MonadReader r m => MonadReader r (MaybeT m) where+    ask = lift ask+    local f m = MaybeT $ local f (runMaybeT m)+    +instance MonadWriter w m => MonadWriter w (MaybeT m) where+    tell = lift . tell+    listen m = MaybeT $ do (x,w) <- listen $ runMaybeT m+                           return $ maybe Nothing (\x' -> Just (x',w)) x+    pass m = MaybeT $ pass $ do +        x <- runMaybeT m; return $ maybe (Nothing,id) (\(y,f) -> (Just y,f)) x++callMaybeT :: Monad m => MaybeT m a -> MaybeT m (Maybe a)+callMaybeT = lift . runMaybeT+++instance MonadWriter w m => MonadWriter w (ListT m) where+    tell = lift . tell+    listen m = ListT $ do (xs,w) <- listen $ runListT m+                          return [(x,w) | x <- xs]+    pass m = ListT $ pass $ do -- not ideal impl, but makes 'censor' work+        ps <- runListT m+        return $ if null ps then ([], id) else (map fst ps, snd (head ps))
+ _darcs/pristine/VobTest.fhs view
@@ -0,0 +1,173 @@+module VobTest where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Utils+import Cairo+import Vobs+import qualified Data.List+import Data.Map (fromList)+import Data.Maybe (fromJust)+import Data.IORef+import Data.Monoid hiding (Endo)+import Control.Applicative+import Control.Monad.State+import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)+import System.Environment (getArgs)+++type Info = (String, Double, Double)+type Data = [(String,[Info])]++--myVob1 :: Vob (String, Int)+--myVob1 = keyVob "1" $ rectBox $ pad 5 $ multiline False 20 "Hello World!"++myVob2 :: Vob (String, Int)+myVob2 = mempty --keyVob "2" $ rectBox $ label "Foo bar baz"++{-+myScene1 :: String -> Data -> Vob (String, Int)+myScene1 t d = mconcat [ stroke $ line (center @@ "1") (center @@ "2"),+                         translate #50 #100 $ myVob2,+                         translate #250 #150  $ myVob1 t d ]+-}++myScene2 :: String -> Data -> Vob (String, Int)+myScene2 t d = translate #350 #400 $ rotate #(-pi/15) $ scale #1.5 $ +    changeSize (\(w,h) -> (w-30, h)) $ myVob1 t d+    +    +myVob1 :: String -> Data -> Vob (String, Int)+myVob1 t d = keyVob ("vob",1) $ {-ownSize $ resize (250, 250) $-} +        pad 20 $ daisy t info where+    info = fromJust (Data.List.lookup t d)+++setSize :: Cx (String, Int) Double -> Cx (String, Int) Double -> +           Endo (Vob (String, Int))+setSize w h = cxLocalR #(!cxMatrix, (!w, !h))++daisy :: String -> [(String, Double, Double)] -> Vob (String, Int)+daisy target distractors = +      mconcat [withDash #[4] #0 $+                   stroke (circle center #(inner + !w * radius))+              | radius <- [0, 1/4, 9/16, 1]]+    & mconcat [(translateTo center $+                   rotate #(((fromIntegral i)::Double) * angle) $+                       translate #inner #0 $ setSize w h $+                           daisyLeaf (distractors !! i))+               & translateTo (center @@ (name i,-1)) +                             (centerVob $ label $ name i)+              | i <- [0..n-1]]+    & translateTo center (centerVob $ label target)+  where+    inner = 20.0 :: Double+    size = #(uncurry min !cxSize)+    w = #((!size - inner)/2); h = #(!w / 20)+    n = length distractors+    name i = case distractors !! i of (r,_,_) -> r+    angle :: Double+    angle = (2.0*pi) / fromIntegral n+++likelihood correct total p = (p ** correct) * ((1 - p) ** (total - correct))++fractions :: Int -> [Double]+fractions n = [fromIntegral i / fromIntegral n | i <- [0..n]]++normalize :: [Double] -> [Double]+normalize xs = map (/s) xs where s = sum xs++accumulate :: [Double] -> [Double]+accumulate = scanl (+) 0++table :: Int -> (Double -> Double) -> [Double]+table steps f = [f (fromIntegral i / len) | i <- [0..steps-1]] where+    len = fromIntegral (steps - 1)++{-+untable :: [Double] -> (Double -> Double)+untable vals = f where+    nvals = fromIntegral (length vals) :: Double; offs = 1 / nvals+    f x = interpolate fract (vals !! idx) (vals !! idx+1) where+        idx = floor (x / offs); fract = x/offs - fromIntegral idx+-}+        +invert :: [Double] -> (Double -> Double)+invert ys = \y -> if y < head ys then 0 else val y 0 ys where+    val v i (x:x':xs) | x <= v && v < x' = i + offs * (v-x) / (x'-x)+                      | otherwise        = val v (i+offs) (x':xs)+    val _ _ _                            = 1+    offs = 1 / fromIntegral (length ys - 1) :: Double++denormalize :: [Double] -> [Double]+denormalize xs = map (* len) xs where len = fromIntegral $ length xs++daisyLeaf :: (String, Double, Double) -> Vob (String, Int)+daisyLeaf (name, correct, total) =+    withColor #color (fill shape) & stroke shape & mconcat pointVobs+    & translateTo (anchor #(correct/total) #0)+                  (ownSize $ keyVob (name,-1) mempty)+  where+    n = 40+    fracts = fractions n+    pointsA = zip fracts ys where+        ys = denormalize $ normalize [likelihood correct total p | p <- fracts]+    pointsB = zip xs ys where+        xs = map f fracts+        f = invert $ accumulate $ normalize [likelihood correct total p | p <- fracts]+        ys = denormalize $ normalize [likelihood correct total p | p <- xs]+    points' = pointsB+    points = points' ++ reverse (map (\(x,y) -> (x,-y)) points')+    pointKeys = [(name, i) | i <- [0..2*n+1]]+    pointVobs = flip map (zip points pointKeys) $ \((x,y),k) -> +        translateTo (anchor #x #y) (keyVob k mempty)+    path = [anchor #0 #0 @@ k | k <- pointKeys]+    shape = moveTo (head path) & mconcat (map lineTo $ tail path) & closePath+    color = interpolate (correct/total) (Color 1 0 0 0.5) (Color 0 1 0 0.5)++main = do +    args <- getArgs+    let fname = if length args == 0 then "DaisyData.txt" else head args+    testdata <- readFile fname >>= return . (read :: String -> Data)++    initGUI+    window <- windowNew+    windowSetTitle window "Vob test"+    windowSetDefaultSize window 700 400++    stateRef <- newIORef (fst $ head testdata)++    let view state    = myVob1 state testdata+        handle _event = do t <- get; let ts = map fst testdata+                           let i = fromJust $ Data.List.elemIndex t ts+                               i' = if i+1 >= length ts then 0 else i+1+                           put (ts !! i')+                           setInterp True++    (canvas, _updateCanvas, _canvasAction) <- vobCanvas stateRef view handle +                                                        (const $ return ()) +                                                        (const $ return ()) +                                                        lightGray 3++    set window [ containerChild := canvas ]+    +    onDestroy window mainQuit+    widgetShowAll window+    mainGUI
+ _darcs/pristine/Vobs.fhs view
@@ -0,0 +1,391 @@+{-# OPTIONS_GHC -fallow-overlapping-instances #-}+module Vobs where++-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup+-- This file is part of Fenfire.+-- +-- Fenfire is free software; you can redistribute it and/or modify it under+-- the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2 of the License, or+-- (at your option) any later version.+-- +-- Fenfire is distributed in the hope that it will be useful, but WITHOUT+-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General+-- Public License for more details.+-- +-- You should have received a copy of the GNU General+-- Public License along with Fenfire; if not, write to the Free+-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,+-- MA  02111-1307  USA++import Utils++import Cairo++import Data.IORef+import System.IO.Unsafe (unsafePerformIO)+import qualified System.Time++import Control.Applicative+import Control.Monad.Reader+import Control.Monad.Trans (liftIO, MonadIO)++import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)+import qualified Graphics.Rendering.Cairo as C+import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))+import qualified Graphics.Rendering.Cairo.Matrix as Matrix+import Graphics.UI.Gtk.Cairo++import Data.List (intersect)+import Data.Map (Map, keys, fromList, toList, insert, empty)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Monoid (Monoid(mempty, mappend))++import Control.Monad (when)+import Control.Monad.State+import Control.Monad.Reader+++type Scene k  = Map k (Maybe (Matrix, Size))+data Vob k    = Vob { defaultSize :: Size,+                      vobScene :: RenderContext k -> Scene k,+                      renderVob :: RenderContext k -> Render () }++type Cx k     = MaybeT (Reader (RenderContext k))++runCx :: RenderContext k -> Cx k a -> Maybe a+runCx cx m = runReader (runMaybeT m) cx++data RenderContext k = RenderContext {+    rcRect :: Rect, rcScene :: Scene k, rcFade :: Double,+    rcFgColor :: Color, rcBgColor :: Color, rcFadeColor :: Color }+    +rcMatrix = fst . rcRect; rcSize = snd . rcRect+    +type View s k  = s -> Vob k+type Handler e s = e -> HandlerAction s++type HandlerAction s = StateT s (StateT (Bool, Bool) IO) ()+++instance Ord k => Monoid (Vob k) where+    mempty = Vob (0,0) (const Map.empty) (const $ return ())+    mappend (Vob (w1,h1) sc1 r1) (Vob (w2,h2) sc2 r2) = Vob (w,h) sc r where+        (w,h) = (max w1 w2, max h1 h2)+        sc cx = Map.union (sc1 cx) (sc2 cx)+        r cx = r1 cx >> r2 cx+        +instance Functor (Cx k) where fmap = liftM+instance Applicative (Cx k) where +    pure = return+    (<*>) = ap++instance Ord k => Cairo (Cx k) (Vob k) where+    cxAsk = asks rcRect+    +    cxLocal rect m = do rect' <- rect; local (\cx -> cx { rcRect = rect' }) m++    cxWrap f (Vob size sc ren) =+        Vob size sc $ \cx -> maybeDo (runCx cx $ f $ ren cx) id+        +    cxLocalR rect (Vob size sc ren) = Vob size+            (\cx -> let msc = liftM sc (upd cx)+                    in Map.mapWithKey (\k _ -> msc >>= (Map.! k)) (sc cx))+            (\cx -> maybe (return ()) ren (upd cx))+        where upd cx = do rect' <- runCx cx rect+                          return $ cx { rcRect = rect' }+    ++defaultWidth  (Vob (w,_) _ _) = w+defaultHeight (Vob (_,h) _ _) = h+++setInterp :: Bool -> HandlerAction s+setInterp interp = lift $ modify $ \(_,handled) -> (interp, handled)++unhandledEvent :: HandlerAction s+unhandledEvent = lift $ modify $ \(interp,_) -> (interp, False)++runHandler handleEvent state event = do+    (((), state'), (interpolate', handled)) <- +        runStateT (runStateT (handleEvent event) state) (False, True)+    return (state',interpolate',handled)+++(@@) :: Ord k => Cx k a -> k -> Cx k a   -- pronounce as 'of'+(@@) x key = do cx <- ask+                rect <- maybeReturn =<< Map.lookup key (rcScene cx)+                local (\_ -> cx { rcRect = rect }) x+++changeSize :: Ord k => Endo Size -> Endo (Vob k)+changeSize f vob = vob { defaultSize = f $ defaultSize vob }++changeContext :: Ord k => Endo (RenderContext k) -> Endo (Vob k)+changeContext f (Vob s sc r) = Vob s (sc . f) (r . f)++changeRect :: Ord k => Endo Rect -> Endo (Vob k)+changeRect f = changeContext (\cx -> cx { rcRect = f $ rcRect cx })++ownSize :: Ord k => Endo (Vob k)+ownSize vob = changeRect (\(m,_) -> (m, defaultSize vob)) vob++invisibleVob :: Ord k => Endo (Vob k)+invisibleVob = cxWrap (const mempty)+    ++comb :: Size -> (RenderContext k -> Vob k) -> Vob k+comb size f = +    Vob size (\cx -> vobScene (f cx) cx) (\cx -> renderVob (f cx) cx)++renderable :: Ord k => Size -> Render () -> Vob k+renderable size ren = Vob size (const Map.empty) $ \cx -> do+    do C.save; C.transform (rcMatrix cx); ren; C.restore+++keyVob :: Ord k => k -> Endo (Vob k)+keyVob key vob = vob { +    vobScene = \cx -> Map.insert key (Just $ rcRect cx) (vobScene vob cx),+    renderVob = \cx -> +        maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->+            renderVob vob $ cx { rcRect = rect } }+        ++rectBox :: Ord k => Endo (Vob k)+rectBox vob = useBgColor (fill extents) & clip extents vob & +              useFgColor (stroke extents)+        ++pangoContext :: PangoContext+pangoContext = unsafePerformIO $ do+    context <- cairoCreateContext Nothing+    desc    <- contextGetFontDescription context+    fontDescriptionSetFamily desc "Sans"+    fontDescriptionSetSize   desc (fromInteger 10)+    contextSetFontDescription context desc+    return context+    ++label :: Ord k => String -> Vob k+label s = unsafePerformIO $ do +    layout  <- layoutText pangoContext s+    (PangoRectangle _ _ w1 h1, PangoRectangle _ _ w2 h2) +        <- layoutGetExtents layout+    let w = max w1 w2; h = max h1 h2+    return $ renderable (realToFrac w, realToFrac h) $ showLayout layout+    +multiline :: Ord k => Bool -> Int -> String -> Vob k+multiline useTextWidth widthInChars s = unsafePerformIO $ do +    layout  <- layoutText pangoContext s+    layoutSetWrap layout WrapPartialWords+    desc    <- contextGetFontDescription pangoContext+    lang    <- languageFromString s+    (FontMetrics {approximateCharWidth=cw, ascent=ascent', descent=descent'})+        <- contextGetMetrics pangoContext desc lang+    let w1 = fromIntegral widthInChars * cw+        h1 = ascent' + descent'+    layoutSetWidth layout (Just w1)+    (PangoRectangle _ _ w2 h2, PangoRectangle _ _ w3 h3) +        <- layoutGetExtents layout+    let w = if useTextWidth then max w2 w3 else w1+        h = maximum [h1, h2, h3]+    return $ renderable (realToFrac w, realToFrac h) $ showLayout layout++                          +fadedColor :: Ord k => Endo (Cx k Color)+fadedColor c = liftM3 interpolate (asks rcFade) (asks rcFadeColor) c++setFgColor :: Ord k => Color -> Endo (Vob k)+setFgColor c = changeContext $ \cx -> cx { rcFgColor = c }++setBgColor :: Ord k => Color -> Endo (Vob k)+setBgColor c = changeContext $ \cx -> cx { rcBgColor = c }++useFgColor :: Ord k => Endo (Vob k)+useFgColor = withColor (fadedColor $ asks rcFgColor)++useBgColor :: Ord k => Endo (Vob k)+useBgColor = withColor (fadedColor $ asks rcBgColor)++useFadeColor :: Ord k => Endo (Vob k)+useFadeColor = withColor (asks rcFadeColor)++fade :: Ord k => Double -> Endo (Vob k)+fade a = changeContext $ \cx -> cx { rcFade = rcFade cx * a }+++centerVob :: Ord k => Endo (Vob k)+centerVob vob = translate (pure (-w/2)) (pure (-h/2)) vob+    where (w,h) = defaultSize vob++               +pad4 :: Ord k => Double -> Double -> Double -> Double -> Endo (Vob k)+pad4 x1 x2 y1 y2 vob = +    changeSize (const (x1+w+x2, y1+h+y2)) $+        changeRect (\(m,(w',h')) -> (f m, (w'-x1-x2, h'-y1-y2))) vob+    where (w,h) = defaultSize vob; f = Matrix.translate x1 y1+    +pad2 :: Ord k => Double -> Double -> Endo (Vob k)+pad2 x y   = pad4 x x y y++pad :: Ord k => Double -> Endo (Vob k)+pad pixels = pad2 pixels pixels+    +    +class Interpolate a where+    interpolate :: Double -> Op a+    +instance Interpolate Double where+    interpolate fract x y = (1-fract)*x + fract*y+    +instance Interpolate Color where+    interpolate fract (Color r g b a) (Color r' g' b' a') =+        Color (i r r') (i g g') (i b b') (i a a') where+            i = interpolate fract++instance Interpolate Matrix where+    interpolate fract (Matrix u v w x y z) (Matrix u' v' w' x' y' z') =+        Matrix (i u u') (i v v') (i w w') (i x x') (i y y') (i z z') where+            i = interpolate fract++interpolateScene :: Ord k => Double -> Op (Scene k)+interpolateScene fract sc1 sc2 =+    fromList [(key, liftM2 f (sc1 Map.! key) (sc2 Map.! key)) +             | key <- interpKeys] where+        interpKeys = intersect (keys sc1) (keys sc2)+        f (m1,(w1,h1)) (m2,(w2,h2)) = (i m1 m2, (i w1 w2, i h1 h2))+        i x y = interpolate fract x y+             ++isInterpUseful :: Ord k => Scene k -> Scene k -> Bool             +isInterpUseful sc1 sc2 = +    not $ all same [(sc1 Map.! key, sc2 Map.! key) | key <- interpKeys]+    where same (a,b) = all (\d -> abs d < 5) $ zipWith (-) (values a) (values b)+          values (Just (Matrix a b c d e f, (w,h))) = [a,b,c,d,e,f,w,h]+          values Nothing = error "shouldn't happen"+          interpKeys = intersect (getKeys sc1) (getKeys sc2)+          getKeys sc = [k | k <- keys sc, isJust (sc Map.! k)]+          +instance Show Modifier where+    show Shift = "Shift"+    show Control = "Control"+    show Alt = "Alt"+    show Apple = "Apple"+    show Compose = "Compose"++timeDbg :: MonadIO m => String -> Endo (m ())+timeDbg s act | False     = do out s; act; out s+              | otherwise = act+    where out t = liftIO $ do time <- System.Time.getClockTime+                              putStrLn $ s ++ " " ++ t ++ "\t" ++ show time+       ++linearFract :: Double -> (Double, Bool)+linearFract x = if (x<1) then (x,True) else (1,False)++bounceFract :: Double -> (Double, Bool)+bounceFract x = (y,cont) where     -- ported from AbstractUpdateManager.java+    x' = x + x*x+    y = 1 - cos (2 * pi * n * x') * exp (-x' * r)+    cont = -(x + x*x)*r >= log 0.02+    (n,r) = (0.4, 2)++++type Anim a = Time -> (Scene a, Bool)  -- bool is whether to re-render++interpAnim :: Ord a => Time -> TimeDiff -> Scene a -> Scene a -> Anim a+interpAnim startTime interpDuration sc1 sc2 time =+    if continue then (interpolateScene fract sc1 sc2, True) else (sc2, False)+    where (fract, continue) = bounceFract ((time-startTime) / interpDuration)+    +noAnim scene = const (scene, False)+    ++vobCanvas :: Ord b => IORef a -> View a b -> Handler Event a -> +                      Handler c a -> (a -> IO ()) -> Color -> TimeDiff ->+                      IO (DrawingArea, Bool -> IO (), c -> IO Bool)+vobCanvas stateRef view eventHandler actionHandler stateChanged +          bgColor animTime = do+    canvas <- drawingAreaNew+    +    widgetSetCanFocus canvas True+    +    animRef <- newIORef (mempty, Map.empty, noAnim Map.empty)+    +    let getWH = do (cw, ch) <- drawingAreaGetSize canvas+                   return (fromIntegral cw, fromIntegral ch)+                   +        getVob = do state <- readIORef stateRef+                    return $ useFadeColor paint & view state+                    +        getRenderContext sc = do +            size <- getWH; return $ RenderContext {+                rcScene=sc, rcRect=(Matrix.identity, size), rcFade=1,+                rcFgColor=black, rcBgColor=white, rcFadeColor=bgColor }+                   +        updateAnim interpolate' = mdo+	    (vob,scene,_) <- readIORef animRef+            vob' <- getVob++            rc' <- getRenderContext scene'+	    let scene' = vobScene vob' rc'+	        +	    time <- scene' `seq` getTime+	    +	    let anim' = if interpolate' && isInterpUseful scene scene'+                        then interpAnim time animTime scene scene'+	                else noAnim scene'++	    writeIORef animRef (vob', scene', anim')+	+	    widgetQueueDraw canvas++        handle handler event = do+            state <- readIORef stateRef++            (state', interpolate', handled) <- +                runHandler handler state event++            when handled $ do writeIORef stateRef state'+                              stateChanged state'+                              updateAnim interpolate'++            return handled++        handleEvent = handle eventHandler++        handleAction = handle actionHandler++    onRealize canvas $ mdo vob <- getVob; rc <- getRenderContext scene+                           let scene = vobScene vob rc+                           writeIORef animRef (vob, scene, noAnim scene)+    +    onConfigure canvas $ \_event -> do updateAnim False; return True++    onKeyPress canvas $ \event -> do+        let Key {eventModifier=mods,eventKeyName=key,eventKeyChar=char} = event+        putStrLn $ show mods++" "++key++" ("++show char++")"++        handleEvent event++    onButtonPress canvas $ \(Button {}) -> do+        widgetGrabFocus canvas+        return True+    +    onExpose canvas $ \(Expose {}) -> do+        drawable <- drawingAreaGetDrawWindow canvas+        +        (vob, _, anim) <- readIORef animRef;  time <- getTime+        let (scene, rerender) = anim time+        rc <- getRenderContext scene+        +        renderWithDrawable drawable $ timeDbg "redraw" $ renderVob vob rc+	+	if rerender then widgetQueueDraw canvas else return ()++        return True+        +    return (canvas, updateAnim, handleAction)
+ _darcs/pristine/data/logo.svg view
@@ -0,0 +1,21 @@+<?xml version="1.0" encoding="ISO-8859-1" standalone="yes"?>+<svg width="506.441" height="709.024">+  <defs> +    <marker id="ArrowEnd" viewBox="0 0 10 10" refX="0" refY="5" +     markerUnits="strokeWidth" +     markerWidth="4" +     markerHeight="3" +     orient="auto"> +        <path d="M 0 0 L 10 5 L 0 10 z" /> +    </marker>+    <marker id="ArrowStart" viewBox="0 0 10 10" refX="10" refY="5" +     markerUnits="strokeWidth" +     markerWidth="4" +     markerHeight="3" +     orient="auto"> +        <path d="M 10 0 L 0 5 L 10 10 z" /> +    </marker> </defs>+<g>+<path style="stroke:#5a5176; stroke-width:18.0; fill:#bdbaff" d="M 253.328 614.689C 182.584 613.866 95.1702 558.196 94.3352 471.647C 103.523 416.226 131.382 420.319 133.052 371.727C 133.052 371.727 164.792 424.115 172.31 470.429C 153.098 352.745 189.015 373.244 175.65 280.615C 175.65 280.615 212.928 323.852 222.115 398.259C 198.729 228.946 233.322 288.245 253.293 94.3352C 268.094 288.148 307.712 228.023 284.324 397.903C 293.512 323.248 330.79 279.866 330.79 279.866C 317.427 372.806 353.34 352.237 334.132 470.315C 341.649 423.845 373.387 371.281 373.387 371.281C 375.058 420.037 402.918 415.93 412.106 471.537C 411.271 558.375 324.071 613.864 253.328 614.689z"/>+</g>+</svg>
+ _darcs/pristine/data/logo48.png view
binary file changed (absent → 1395 bytes)
+ _darcs/pristine/fenfire.cabal view
@@ -0,0 +1,46 @@+Name:           fenfire+Version:        0.1+License:        GPL+License-file:   LICENSE+Author:         Benja Fallenstein and Tuukka Hastrup+Maintainer:     fenfire-dev@nongnu.org+Synopsis:       Graph-based notetaking system+Description:    Fenfire is a graph-based notetaking system. (We're+                planning to add a kitchen sink soon.) It is developed +                on the channel #fenfire on the Freenode IRC network.+Category:       User Interfaces+Stability:      alpha+Homepage:       http://fenfire.org/+Build-Depends:  base, HaXml, gtk, mtl, unix, cairo, harp, template-haskell+Data-Files:     data/logo.svg data/logo48.png++Executable:     fenfire+Main-Is:        Fenfire.hs+Other-Modules:  Fenfire, Vobs, RDF, Cache, Cairo, Utils, Raptor, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations -main-is Fenfire.main+Extra-Libraries: raptor++Executable:     functortest+Main-Is:        FunctorTest.hs+Other-Modules:  FunctorTest, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations +                -main-is FunctorTest.main++Executable:     vobtest+Main-Is:        VobTest.hs+Other-Modules:  VobTest, Vobs, Cairo, Utils, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations -main-is VobTest.main++Executable:     darcs2rdf+Main-Is:        Darcs2RDF.hs+Other-Modules:  Darcs2RDF, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations +                -main-is Darcs2RDF.main
+ _darcs/pristine/test.nt view
@@ -0,0 +1,35 @@+<ex:24144517> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:617188915> .+<ex:24144517> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:830264096> .+<ex:830264096> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-543050792> .+<ex:830264096> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-380279150> .+<ex:830264096> <http://www.w3.org/2000/01/rdf-schema#label> "node A" .+<ex:617188915> <http://www.w3.org/2000/01/rdf-schema#label> "node B" .+<ex:24144517> <http://www.w3.org/2000/01/rdf-schema#label> "Home" .+<ex:-303448107> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:-2127956011> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-2127956011> .+<ex:423328881> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:423328881> .+<ex:1363356230> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:1363356230> .+<ex:-1298412670> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-1298412670> .+<ex:518008873> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:518008873> .+<ex:489795392> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:489795392> .+<ex:-1985581258> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-1985581258> .+<ex:1364607755> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:1364607755> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:-372997138> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-372997138> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:217828885> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:217828885> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:132523219> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:132523219> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:-607838537> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-607838537> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:1989159944> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:1989159944> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .
+ data/logo.svg view
@@ -0,0 +1,21 @@+<?xml version="1.0" encoding="ISO-8859-1" standalone="yes"?>+<svg width="506.441" height="709.024">+  <defs> +    <marker id="ArrowEnd" viewBox="0 0 10 10" refX="0" refY="5" +     markerUnits="strokeWidth" +     markerWidth="4" +     markerHeight="3" +     orient="auto"> +        <path d="M 0 0 L 10 5 L 0 10 z" /> +    </marker>+    <marker id="ArrowStart" viewBox="0 0 10 10" refX="10" refY="5" +     markerUnits="strokeWidth" +     markerWidth="4" +     markerHeight="3" +     orient="auto"> +        <path d="M 10 0 L 0 5 L 10 10 z" /> +    </marker> </defs>+<g>+<path style="stroke:#5a5176; stroke-width:18.0; fill:#bdbaff" d="M 253.328 614.689C 182.584 613.866 95.1702 558.196 94.3352 471.647C 103.523 416.226 131.382 420.319 133.052 371.727C 133.052 371.727 164.792 424.115 172.31 470.429C 153.098 352.745 189.015 373.244 175.65 280.615C 175.65 280.615 212.928 323.852 222.115 398.259C 198.729 228.946 233.322 288.245 253.293 94.3352C 268.094 288.148 307.712 228.023 284.324 397.903C 293.512 323.248 330.79 279.866 330.79 279.866C 317.427 372.806 353.34 352.237 334.132 470.315C 341.649 423.845 373.387 371.281 373.387 371.281C 375.058 420.037 402.918 415.93 412.106 471.537C 411.271 558.375 324.071 613.864 253.328 614.689z"/>+</g>+</svg>
+ data/logo48.png view
binary file changed (absent → 1395 bytes)
+ fenfire.cabal view
@@ -0,0 +1,46 @@+Name:           fenfire+Version:        0.1+License:        GPL+License-file:   LICENSE+Author:         Benja Fallenstein and Tuukka Hastrup+Maintainer:     fenfire-dev@nongnu.org+Synopsis:       Graph-based notetaking system+Description:    Fenfire is a graph-based notetaking system. (We're+                planning to add a kitchen sink soon.) It is developed +                on the channel #fenfire on the Freenode IRC network.+Category:       User Interfaces+Stability:      alpha+Homepage:       http://fenfire.org/+Build-Depends:  base, HaXml, gtk, mtl, unix, cairo, harp, template-haskell+Data-Files:     data/logo.svg data/logo48.png++Executable:     fenfire+Main-Is:        Fenfire.hs+Other-Modules:  Fenfire, Vobs, RDF, Cache, Cairo, Utils, Raptor, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations -main-is Fenfire.main+Extra-Libraries: raptor++Executable:     functortest+Main-Is:        FunctorTest.hs+Other-Modules:  FunctorTest, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations +                -main-is FunctorTest.main++Executable:     vobtest+Main-Is:        VobTest.hs+Other-Modules:  VobTest, Vobs, Cairo, Utils, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations -main-is VobTest.main++Executable:     darcs2rdf+Main-Is:        Darcs2RDF.hs+Other-Modules:  Darcs2RDF, FunctorSugar+GHC-Options:    -fglasgow-exts -hide-package haskell98 -Wall +                -fno-warn-unused-imports -fno-warn-missing-signatures+                -fno-warn-orphans -fno-warn-deprecations +                -main-is Darcs2RDF.main
+ test.nt view
@@ -0,0 +1,35 @@+<ex:24144517> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:617188915> .+<ex:24144517> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:830264096> .+<ex:830264096> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-543050792> .+<ex:830264096> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-380279150> .+<ex:830264096> <http://www.w3.org/2000/01/rdf-schema#label> "node A" .+<ex:617188915> <http://www.w3.org/2000/01/rdf-schema#label> "node B" .+<ex:24144517> <http://www.w3.org/2000/01/rdf-schema#label> "Home" .+<ex:-303448107> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:-2127956011> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-2127956011> .+<ex:423328881> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:423328881> .+<ex:1363356230> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:1363356230> .+<ex:-1298412670> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-1298412670> .+<ex:518008873> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:518008873> .+<ex:489795392> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:489795392> .+<ex:-1985581258> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-380279150> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-1985581258> .+<ex:1364607755> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:1364607755> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:-372997138> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-372997138> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:217828885> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:217828885> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:132523219> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:132523219> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:-607838537> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:-607838537> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .+<ex:1989159944> <http://www.w3.org/2000/01/rdf-schema#label> "" .+<ex:1989159944> <http://www.w3.org/2000/01/rdf-schema#seeAlso> <ex:-303448107> .