packages feed

marxup 3.0.0.1 → 3.1.0.0

raw patch · 25 files changed

+1027/−1564 lines, 25 filesdep +haskell-src-extsdep +lp-diagramsdep +marxupdep −cubicbezierdep −glpk-hsdep −polynomials-bernsteindep ~basedep ~filepathdep ~lensnew-component:exe:marxupnew-component:exe:marxup-example

Dependencies added: haskell-src-exts, lp-diagrams, marxup

Dependencies removed: cubicbezier, glpk-hs, polynomials-bernstein, typography-geometry, vector

Dependency ranges changed: base, filepath, lens

Files

Config.hs view
@@ -4,8 +4,6 @@ import Data.Configurator import Data.Configurator.Types (Value (..),Configured (..)) import System.IO.Unsafe-import Data.Traversable-import Control.Applicative  data List a = L [a]
+ Literate.hs view
@@ -0,0 +1,27 @@+module Literate where++import Data.Monoid+import Data.DList hiding (foldr, map)+import MarXupParser+import Data.List (isPrefixOf)+import Output++----------------------------------------------+-- Top-level generation++rHaskells :: [Haskell] -> Doc+rHaskells xs = mconcat $ map rHaskell xs++rHaskell :: Haskell -> DList Char+rHaskell (HaskLn pos) = oPos pos <> text "\n"+rHaskell (Quote xs) = mconcat $ map rMarxup xs+rHaskell _ = mempty++rMarxup :: MarXup -> Doc+rMarxup (Unquote _ [(_,HaskChunk fct),(position,Quote code)]) | "haskell" `isPrefixOf` fct = oPos position <> foldMap rInlineHask code+rMarxup _ = mempty++rInlineHask :: MarXup -> Doc+rInlineHask (TextChunk x) = text x+rInlineHask _ = mempty+
+ Main.hs view
@@ -0,0 +1,35 @@+import Text.ParserCombinators.Parsek.Position++import System.Environment+import Data.Monoid+import Data.DList hiding (foldr, map)+import MarXupParser+import qualified Literate as Lit+import Output++rHaskells :: [Haskell] -> Doc+rHaskells xs = mconcat $ map rHaskell xs++rHaskell :: Haskell -> DList Char+rHaskell (HaskChunk s) = text s+rHaskell (HaskLn pos) = oPos pos+rHaskell (Quote xs) = parens $ oConcat $ map rMarxup xs+rHaskell (List xs) = brackets $ rHaskells xs+rHaskell (Parens xs) = parens $ rHaskells xs+rHaskell (String xs) = doubleQuotes $ text xs++rArg :: (SourcePos, Haskell) -> Doc+rArg (pos,h) = oPos pos <> parens (rHaskell h)++rMarxup :: MarXup -> Doc+rMarxup (TextChunk s) = oText s+rMarxup (Unquote var val) =+  maybe mempty (\(pos,x) -> oPos pos <> text (x <> "<-")) var <>+  text "element" <+> parens (hcat $ map rArg val)+rMarxup (Comment _) = mempty++main :: IO ()+main = do+  x : y : z : _ <- getArgs+  parseFile y $ \res -> writeFile z $ render (rHaskells res <> Lit.rHaskells res)+
− Main3.hs 
@@ -1,188 +0,0 @@-{-# LANGUAGE TupleSections, FlexibleInstances, TransformListComp #-}-import Text.ParserCombinators.Parsek.Position--import Data.Char-import Data.List-import System.IO-import System.Environment-import Control.Monad-import Data.DList hiding (map,foldr)-import Data.Monoid-import GHC.Exts (the,groupWith)-import Config---- todo: parse haskell comments----------------------- Simple printing combinators, which do not add nor remove line breaks--type Doc = DList Char--text = fromList-x <+> y =  x <> text " " <> y-oChar = singleton-parens s = oChar '(' <> s <> oChar ')'-braces s = oChar '{' <> s <> oChar '}'-brackets s = oChar '[' <> s <> oChar ']'-doubleQuotes s = oChar '"' <> s <> oChar '"'--int x = text $ show x-hcat :: [Doc] -> Doc-hcat = foldr (<>) mempty-punctuate t = map (<> t)-render :: Doc -> String-render = toList----------------------------------------------- Output combinators--oPos :: SourcePos -> Doc-oPos EOF = mempty-oPos p = text "{-# LINE" <+> int (sourceLine p) <+> text (show (sourceName p)) <+> text "#-}"--oText :: String -> Doc-oText x = text "textual" <+> text (show x)--oMappend :: [Doc] -> Doc-oMappend [] = text "(return ())"-oMappend [x] = parens x-oMappend l = text "do" <+> braces (text "rec" <+> braces (hcat (punctuate (text ";") binds)) <> text ";" <> ret)-  where binds = init l-        ret = last l--------------------------------------------------- Parsing helpers--satisfy' :: (String -> Bool) -> Parser Char-satisfy' p = do-  l <- look-  unless (p l) $-    fail "Unexpected leading string"-  anySymbol--munch',munch1' :: (String -> Bool) -> Parser String-munch' p = scan =<< look- where-  scan (c:cs) | p (c:cs) = (:) <$> anySymbol <*> scan cs-  scan _            = pure []--munch1' p = (:) <$> satisfy' p <*> munch' p---- | A chunck not containing some strings-pChunk' :: [String] -> Parser String-pChunk' stops = munch1' (\l -> not $ any (`isPrefixOf` l) stops)----- | A chunk not containing some chars.-pChunk :: [Char] -> Parser String-pChunk stops = munch1 (not . (`elem` stops))--------------------------------------------------- Parsing combinators--anyQuoteStrings :: [String]-anyQuoteStrings = concatMap (\(x,y) -> [x,y]) quoteStrings--pTextChunk = oText <$> pChunk' ("\n" : commentString : antiQuoteStrings ++ anyQuoteStrings) <?> "Text chunk"-pHaskChunk = text <$> pChunk' (map box "\n\"[]()" ++ map fst quoteStrings) <?> "Haskell chunk"-    -- we keep track of balancing--pWPos :: Parser Doc-pWPos = do-  char '\n'-  pos <- getPosition-  return $ oPos pos <> text "\n"--pHaskLn = pWPos -- before each newline, tell GHC where we are.-pTextLn = (oText "\n" <>) <$> pWPos-  -- add code to output a newline; and insert a newline in the code.--box = (:[])--pString :: Parser Doc-pString = do-  char '"'-  result <- many (string "\\\"" <|> pChunk ['"'])-  char '"'-  return $ doubleQuotes . hcat . map text $ result---- | Parse some Haskell code with markup inside.-pHask :: Parser Doc-pHask =-  (hcat <$> many ((brackets <$> pArg "[]") <|>-                  (parens   <$> pArg "()") <|>-                  (parens   <$> pTextArg ) <|> pString <|> pHaskChunk <|> pHaskLn))---- | Parse a text argument to an element-pTextArg' :: String -> String -> Parser Doc-pTextArg' open close = label "quoted text" $-  string open *>-  (oMappend <$> many (pElement <|> pTextChunk <|> pTextLn <|> pComment))-  <* string close--pTextArg :: Parser Doc-pTextArg = choice $ map (uncurry pTextArg') quoteStrings--pArg :: String -> Parser Doc-pArg [open,close] = char open *> pHask <*  char close--isIdentChar :: Char -> Bool-isIdentChar x = isAlphaNum x || (x `elem` "\'_")--pIdent :: Parser Doc-pIdent = text <$> munch1 isIdentChar <?> "identifier"--pArgument :: Parser Doc-pArgument = (pArg "()" <|> (brackets <$> pArg "[]") <|> pTextArg <|> pString) <?> "argument"--pElement :: Parser Doc-pElement = label "Haskell element" $ do-  choice $ map string $ antiQuoteStrings-  var <- ((<+> text "<-") <$> (pIdent <* string "<-")) <<|> pure mempty-  val <- ((:) <$> pIdent <*> manyGreedy pArgument) <|> (box <$> pArg "()")-  return $ var <> text "element" <+> parens (hcat $ fmap parens val)--commentString :: String-commentString = "%%"--pComment :: Parser Doc-pComment = label "Comment" $ do-  string commentString-  munch (/= '\n')-  string "\n"-  return mempty--main :: IO ()-main = do-  x : y : z : _ <- getArgs-  putStrLn x-  putStrLn y-  putStrLn z-  p <- parseFromFile (pHask <* endOfFile) completeResults y-  case p of-    Left e -> handleErr e-    Right [res] -> writeFile z $ render res-    Right _ -> hPutStrLn stderr "Amibiguous input!"--handleErr e =-   sequence_-          [ hPutStrLn stderr (show $ maybePosToPos $ the pos) >>-            hPutStrLn stderr ("  Expected:" ++ (intercalate " or " $ nub what))-           | (exps,_why) <- e, (what,pos) <- exps, then group by pos using groupWith, then reverse ]--instance Show (DList Char) where-  show x = show $ render x----- Tests-testHask = parse "<interactive>" pHask completeResults "arst « text @z<-fct[x](y) awft"-testHask2 = parse "<interactive>" pHask completeResults "ars(t) « text @z<-fct[x](y) » awft"-testText2 = parse "<interactive>" pTextArg completeResults "« text @fct(x »"-testText3 = parse "<interactive>" pTextArg completeResults "« 1 @x 2 @y 3 @x 4 »"-testElem = parse "<interactive>" pElement completeResults "@x<-fct(x « yop »)[y]"-testChunk = parse "<interactive>" pHaskChunk completeResults "t"-testArg = parse "<interactive>" (pArg "()") completeResults "()"--terr e  = case e of-    Left x -> handleErr x-    Right [res] -> putStrLn $ render res
MarXup/DerivationTrees.hs view
@@ -1,19 +1,15 @@-{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, RecordWildCards, PostfixOperators, LiberalTypeSynonyms, TypeOperators, OverloadedStrings, PackageImports #-}+{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, RecordWildCards, PostfixOperators, LiberalTypeSynonyms, TypeOperators, OverloadedStrings, PackageImports, ScopedTypeVariables #-}  module MarXup.DerivationTrees ( -- * Basics module Data.Monoid, module Data.LabeledTree, --- * Derivation' building--- axiom, rule, etc, aborted, -emptyDrv, haltDrv, haltDrv', delayPre,-dummy, rule, Derivation, Premise, Rule(..), ---- * Links-LineStyle,defaultLink,Link(..),- -- * Engine+haltDrv,+module Graphics.Diagrams.DerivationTrees,++-- * Frontend derivationTree, derivationTreeD  ) where@@ -21,60 +17,27 @@ -- import DerivationTrees.Basics import Data.List import Control.Monad.Writer -import Control.Applicative  import Data.LabeledTree import Data.Monoid import MarXup (element) import MarXup.Tex hiding (label)-import MarXup.MultiRef-import MarXup.Diagram as D-import qualified Data.Tree as T----------------------- Basics--type LineStyle = PathOptions -> PathOptions--data Link = Link {label :: Tex (), linkStyle :: LineStyle, steps :: Int}  -- ^ Regular link-          | Delayed -- ^ automatic delaying--defaultLink :: Link-defaultLink = Link mempty (denselyDotted . outline "black")  0------------------------data Rule = Rule {ruleStyle :: LineStyle, delimiter :: Tex (), ruleLabel :: Tex (), conclusion :: Tex ()}---  deriving Show--type Premise = Link ::> Derivation-type Derivation = Tree Link Rule------------------------------------------------------- Delay--depth (Link{steps} ::> Node _ ps) = 1 + steps + maximum (0 : map depth ps)--isDelayed :: Premise -> Bool-isDelayed (Delayed{} ::> _) = True-isDelayed _ = False+import Graphics.Diagrams.DerivationTrees+import MarXup.Diagram -delayPre s (Link {..} ::> j) = Link {steps = s, ..} ::> j+----------------------------------------------------------+-- Tikzify -delayD :: Derivation -> Derivation-delayD (Node r ps0) = Node r (map delayP ps)-    where ps = fmap (fmap delayD) ps0-          ps' = filter (not . isDelayed) ps-          delayP (Delayed{..} ::> d) = defaultLink {steps = 1 + maximum (0 : map depth ps')} ::> d-          delayP p = p+derivationTreeD :: Derivation TeX -> TeX+derivationTreeD d = element $ (derivationTreeDiag $ delayD d :: TexDiagram ())  ---------------------------------------------------------- -- TeXify   --- | Render a derivation tree without using metapost drv package (links will not be rendered properly)-derivationTree :: Derivation -> TeX+-- | Render a derivation tree using simple latex only (links will not be rendered properly)+derivationTree :: Derivation TeX -> TeX derivationTree = stringizeTex -stringizeTex :: Derivation -> TeX+stringizeTex :: Derivation TeX -> TeX stringizeTex (Node Rule {..} premises) = braces $ do   cmd0 "displaystyle" -- so that the text does not get smaller   cmdn "frac" [mconcat $@@ -84,145 +47,7 @@   braces $ do cmd0 "small"               ruleLabel -------------------------------------------------------------- Tikzify--derivationTreeD :: Derivation -> Tex ()-derivationTreeD d = element $ derivationTreeDiag $ delayD d--derivationTreeDiag :: Derivation -> Diagram ()-derivationTreeDiag d = do-  [h] <- newVars [ContVar] -- the height of a layer in the tree.-  minimize h-  h >== 1-  tree@(T.Node (_,n,_) _) <- toDiagram h d-  forM_ (T.levels tree) $ \ls ->-    case ls of-      [] -> return ()-      (_:ls') -> forM_ (zip ls ls') $ \((_,_,l),(r,_,_)) ->-        (l + Point 10 0) `westOf` r-  let leftFringe = map head nonNilLevs-      rightFringe = map last nonNilLevs-      nonNilLevs = filter (not . null) $ T.levels tree-  [leftMost,rightMost] <- newVars [ContVar,ContVar]-  forM_ leftFringe $ \(p,_,_) ->-    leftMost <== xpart p-  forM_ rightFringe $ \(_,_,p) ->-    xpart p <== rightMost-  minimize $ 10 *- (rightMost - leftMost)-  n # Center .=. Point 0 0--toDiagPart :: Expr -> Premise -> Diagram (T.Tree (Point,Anchorage,Point))-toDiagPart layerHeight (Link{..} ::> rul)-  | steps == 0 = toDiagram layerHeight rul-  | otherwise = do-    above@(T.Node (_,concl,_) _) <- toDiagram layerHeight rul-    ptObj <- vrule-    let pt = ptObj # S-    pt `eastOf` (concl # W)-    pt `westOf` (concl # E)-    xpart pt =~= xpart (concl # Center)-    let top = ypart (concl # S)-    ypart pt + (fromIntegral steps *- layerHeight) === top-    using linkStyle $ path $ polyline [ptObj # Base,Point (xpart pt) top]-    let embedPt 1 x = T.Node (concl # W,ptObj,concl # E) [x]-        embedPt n x = T.Node (pt,ptObj,pt) [embedPt (n-1) x]-    return $ embedPt steps above---- | @chainBases distance objects@--- - Ensures that all the objects have the same baseline.--- - Separates the objects by the given distance--- - Returns an object encompassing the group, with a the baseline set correctly.--- - Returns the average distance between the objects-   -chainBases :: Expr -> [Anchorage] -> Diagram (Anchorage,Expr)-chainBases _ [] = do-  o <- box-  return (o,0)-chainBases spacing ls = do-  grp <- box-  forM_ [Base,N,S] $ \ anch -> do-    D.align ypart $ map (# anch) (grp:ls)-  dxs <- forM (zip ls (tail ls)) $ \(x,y) -> do-    let dx = xdiff (x # E) (y # W)-    dx >== spacing-    return dx-  D.align xpart [grp # W,head ls # W]-  D.align xpart [grp # E,last ls # E]-  return (grp,avg dxs)---- | Make an horizontally flexible box of glue.-mkHGlue :: Expr -> Expr -> Diagram Anchorage-mkHGlue minimumWidth preferredWidth = do-  g <- box-  width g >== minimumWidth-  width g =~= preferredWidth-  return g---- | Put object in a box of the same vertical extent, and baseline,--- but whose height can be bigger.-relaxHeight o = do-  b <- box-  -- using (outline "green")$ traceBounds o-  D.align xpart [b#W,o#W]-  D.align xpart [b#E,o#E]-  D.align ypart [b#Base,o#Base]-  o `fitsVerticallyIn` b-  return b--toDiagram :: Expr -> Derivation -> Diagram (T.Tree (Point,Anchorage,Point))-toDiagram layerHeight (Node Rule{..} premises) = do-  ps <- mapM (toDiagPart layerHeight) premises-  concl <- relaxHeight =<< extend 1.5 <$> texBox conclusion-  -- using (outline "red")$ traceBounds concl-  lab <- texBox ruleLabel--  -- Grouping-  (psGrp,premisesDist) <- chainBases 10 [p | T.Node (_,p,_) _ <- ps]-  -- using (outline "blue" . denselyDotted) $ traceBounds psGrp-  height psGrp === layerHeight--  -- Sepaartion rule-  separ <- hrule-  separ # N .=. psGrp # S-  align ypart [concl # N,separ # S]-  minimize $ width separ-  psGrp `fitsHorizontallyIn` separ-  concl `fitsHorizontallyIn` separ--  -- rule label-  lab # BaseW .=. separ # E + Point 3 (negate 1)---  -- layout hints (not necessary for "correctness")-  let xd = xdiff (separ # W) (psGrp # W)-  xd   === xdiff (psGrp # E) (separ # E) -  relax 2 $ (2 *- xd) =~= premisesDist-  -- centering of conclusion-  xd' <- absoluteValue $ xdiff (separ # Center) (concl # Center)-  relax 3 $ minimize xd'--  -- draw the rule.-  localPathOptions ruleStyle $ path $ polyline [separ # W,separ # E]-  return $ T.Node (separ # W, concl, lab # E) ps----------------------------rule ruleLabel conclusion = Rule {delimiter = mempty, ruleStyle = outline "black", ..}--dummy :: Rule-dummy = (rule mempty mempty) {ruleStyle = const defaultPathOptions}-emptyDrv = Node dummy []---- abortDrv (Node Rule {..} _) = Node Rule {ruleStyle = Waved, ..} []---- | Used when the rest of the derivation is known.-haltDrv' :: Tex () -> Derivation -> Derivation-haltDrv' tex (Node r _) = Node r {ruleStyle = noOutline}-     [defaultLink {steps = 1, label = tex} ::> emptyDrv]---- | More compact variant-haltDrv :: Tex () -> Derivation -> Derivation+-- -- | More compact variant+haltDrv :: TeX -> Derivation TeX -> Derivation TeX haltDrv t (Node r _) = Node r [defaultLink ::> Node dummy {conclusion = cmd "vdots" nil >> cmd "hspace" (tex "2pt") >> t} []]
MarXup/Diagram.hs view
@@ -1,7 +1,4 @@ module MarXup.Diagram (module D) where -import MarXup.Diagram.Layout as D-import MarXup.Diagram.Path as D-import MarXup.Diagram.Point  as D-import MarXup.Diagram.Object as D+import Graphics.Diagrams as D import MarXup.Diagram.Tikz as D
− MarXup/Diagram/Graphviz.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module MarXup.Diagram.Graphviz (graph) where--import MarXup.Tex-import MarXup.Diagram.Point as D-import MarXup.Diagram.Object as D-import MarXup.Diagram.Tikz as D-import MarXup.Diagram.Layout-import MarXup.Diagram.Path-import Data.GraphViz as G-import Data.GraphViz.Attributes.Complete as G-import Data.GraphViz.Parsing as G-import qualified Data.GraphViz.Types.Generalised as Gen-import Data.GraphViz.Commands.IO as G--- import qualified Data.Text.Lazy.Internal as T-import qualified Data.Text.Lazy as T-import System.IO.Unsafe (unsafePerformIO)--- import Data.Traversable-import Data.Foldable-import Control.Lens (set)--graph :: (PrintDotRepr g n, ParseDot n, PrintDot n) => GraphvizCommand -> g n -> Dia-graph cmd gr = graphToDiagram $ layout cmd gr--layout :: (PrintDotRepr g n, ParseDot n, PrintDot n) => GraphvizCommand -> g n -> Gen.DotGraph n-layout command input = parseIt' $ unsafePerformIO $ graphvizWithHandle command input DotOutput hGetStrict --pos (Pos p) = Just p-pos _= Nothing--lpos (LPos p) = Just p-lpos _= Nothing--shapeA (Shape s) = Just s-shapeA _ = Nothing--widthA (Width s) = Just s-widthA _ = Nothing--labelA (Label l) = Just l-labelA _ = Nothing--arrowHeadA (ArrowHead a) = Just a-arrowHeadA _ = Nothing--readAttr :: Monad m => (Attribute -> Maybe a) -> [Attribute] -> (a -> m ()) -> m ()-readAttr f as k = readAttr' f as k (return ())--readAttr' :: (Attribute -> Maybe a) -> [Attribute] -> (a -> k) -> k -> k-readAttr' f as k1 k2 = case [x | Just x <- map f as] of-  (x:_) -> k1 x-  _ -> k2---pt' (G.Point x y _z _forced) = D.Point x y-pt = unfreeze . pt'--diaSpline (w:x:y:z:rest) = curveSegment w x y z:diaSpline (z:rest)-diaSpline _ = []---- ToTip | CircleTip | NoTip | StealthTip | LatexTip | ReversedTip LineTip | BracketTip | ParensTip-tipTop def (AType [(_,NoArrow)]) = NoTip-tipTop def (AType [(_,Normal)]) = LatexTip-tipTop def (AType [(_,DotArrow)]) = CircleTip-tipTop def (AType [(_,Vee)]) = StealthTip-tipTop def _ = def--renderLab l p = do-  l' <- labelObj $ tex $ T.unpack $ l-  l' # D.Center .=. pt p--graphToDiagram :: Gen.DotGraph n -> Dia-graphToDiagram (Gen.DotGraph _strict _directed _grIdent stmts) = do-  forM_ stmts $ \ stmt -> case stmt of-    (Gen.DE (DotEdge _from _to attrs)) -> do-      diaRaw $ "%Edge: " ++ show attrs ++ "\n"-      let toTip = readAttr' arrowHeadA attrs (tipTop ToTip) ToTip-      readAttr labelA attrs $ \(StrLabel l) ->-        readAttr lpos attrs $ \p -> -        renderLab l p-      readAttr pos attrs $ \(SplinePos splines) ->-        forM_ splines $ \Spline{..} -> do-          let mid = diaSpline $ map pt' splinePoints-          let beg = case (startPoint,splinePoints) of-                (Just p,q:_) -> [lineSegment (pt' p) (pt' q)]-                _ -> []-          let end = case (endPoint,reverse splinePoints) of-                (Just p,q:_) -> [lineSegment (pt' q) (pt' p)]-                _ -> []-          using (set endTip toTip) $-            draw $ frozenPath $ fromBeziers (beg ++ mid ++ end)--    (Gen.DN (DotNode _nodeIdent attrs)) -> do-      diaRaw $ "%Node: " ++ show attrs ++ "\n"-      readAttr pos   attrs $ \(PointPos p) -> do-        readAttr labelA attrs $ \l -> do-          case l of-            StrLabel l -> renderLab l p-        readAttr widthA attrs $ \w ->-         readAttr shapeA attrs $ \s ->-          case s of-            Circle -> do-              draw $ path $ circle (pt p) (constant $ inch (w/2))-            _ -> return ()-    _ -> return ()--inch x = 72 * x--
− MarXup/Diagram/Layout.hs 
@@ -1,203 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}--module MarXup.Diagram.Layout (module MarXup.Diagram.Layout) where-import Control.Monad.LPMonad-import Prelude hiding (sum,mapM_,mapM,concatMap)-import Control.Monad.RWS hiding (forM,forM_,mapM_,mapM)-import Data.LinearProgram-import Data.LinearProgram.Common as MarXup.Diagram.Layout (VarKind(..)) -import Data.LinearProgram.LinExpr-import Data.Map (Map)-import qualified Data.Map as M-import Control.Lens hiding (element)-import Data.String--- import MarXup-import Data.Traversable-import Data.Foldable-import Control.Applicative-import System.IO.Unsafe-import MarXup.MultiRef-import MarXup.Tex--type LPState = LP Var Constant--type Solution = Map Var Double-type Constant = Double---- | Expressions are linear functions of the variables-type Expr = LinExpr Var Constant--newtype Decoration = Decoration String-data LineTip = ToTip | CircleTip | NoTip | StealthTip | LatexTip | ReversedTip LineTip | BracketTip | ParensTip-type Color = String-data LineCap = ButtCap | RectCap | RoundCap-data LineJoin = MiterJoin | RoundJoin | BevelJoin-type DashPattern = [(Constant,Constant)]-data PathOptions = PathOptions-                     {_drawColor :: Maybe Color-                     ,_fillColor :: Maybe Color-                     ,_lineWidth :: Constant-                     ,_startTip  :: LineTip-                     ,_endTip    :: LineTip-                     ,_lineCap   :: LineCap-                     ,_lineJoin  :: LineJoin-                     ,_dashPattern :: DashPattern-                     ,_decoration :: Decoration-                     }-$(makeLenses ''PathOptions)--data Env = Env {_diaSolution :: Solution-               ,_diaTightness :: Constant -- ^ Multiplicator to minimize constraints-               ,_diaPathOptions :: PathOptions}--$(makeLenses ''Env)--defaultPathOptions :: PathOptions-defaultPathOptions = PathOptions-  {_drawColor = Nothing-  ,_fillColor = Nothing-  ,_lineWidth = 0.4-  ,_startTip  = NoTip-  ,_endTip    = NoTip-  ,_lineCap   = ButtCap-  ,_lineJoin  = MiterJoin-  ,_dashPattern = []-  ,_decoration = Decoration ""-  }--newtype Diagram a = Dia (RWST Env () (Var,LPState) Multi a)-  deriving (Monad, Applicative, Functor, MonadReader Env)--type Dia = Diagram ()--instance MonadState LPState Diagram where-  get = Dia $ snd <$> get-  put y = Dia $ do-    (x,_) <- get-    put (x,y)------------------ Diagrams--runDiagram :: Diagram a -> Multi a-runDiagram (Dia diag) = do-  rec (a,(_,problem),_) <- runRWST diag (Env solution 1 defaultPathOptions)-                                        (Var 0,LP Min M.empty [] M.empty M.empty)-      let solution = case unsafePerformIO $ glpSolveVars simplexDefaults problem of-            (_retcode,Just (_objFunc,s)) -> s-            (retcode,Nothing) -> error $ "ret code = " ++ show retcode-  -- Raw Normal $ "%problem solved: " ++ show problem ++ "\n"-  return a--diaRawTex :: Tex a -> Diagram a-diaRawTex (Tex t) = Dia $ lift t--diaRaw :: String -> Dia-diaRaw = diaRawTex . tex--relax factor = local (over diaTightness (/ factor)) --instance Monoid (Diagram ()) where-  mempty = return ()-  mappend = (>>)--instance IsString (Diagram ()) where-  fromString = diaRawTex . tex------------------- Variables-varValue :: Var -> Diagram Double-varValue v = M.findWithDefault 0 v <$> view diaSolution--rawNewVar :: Diagram Var-rawNewVar = Dia $ do-      (Var x,y) <- get-      put $ (Var (x+1),y)-      return $ Var x--newVars :: [VarKind] -> Diagram [Expr]-newVars kinds = newVars' (zip kinds (repeat Free))--newVars' :: [(VarKind,Bounds Constant)] -> Diagram [Expr]-newVars' kinds = forM kinds $ \(k,b) -> do-  v <- rawNewVar-  setVarKind v k-  setVarBounds v b-  return $ variable v--infix 4 <==,===,>==--------------------- Expressions-instance Fractional Expr where-  fromRational ratio = constant (fromRational ratio)--instance Num Expr where-  fromInteger x = LinExpr M.empty (fromInteger x)-  negate = neg-  (+) = (^+^)-  (-) = (^-^)--valueOf :: Expr -> Diagram Double-valueOf (LinExpr m c) = do-  vs <- forM (M.assocs m) $ \(v,scale) ->-    (scale *) <$> varValue v-  return $ sum $ c:vs--variable :: Var -> Expr-variable v = LinExpr (var v) 0--constant :: Constant -> Expr-constant c = LinExpr M.empty c--(*-) :: Module Constant a => Constant -> a -> a-(*-) = (*^)-infixr 6 *---avg :: Module Constant a => [a] -> a-avg xs = (1/fromIntegral (length xs)) *- gsum xs--absoluteValue :: Expr -> Diagram Expr-absoluteValue x = do-  [t1,t2] <- newVars' [(ContVar,LBound 0),(ContVar,LBound 0)]-  t1 - t2 === x-  return $ t1 + t2--satAll :: (Expr -> a -> Diagram b) -> [a] -> Diagram Expr-satAll p xs = do-  [m] <- newVars [ContVar]-  mapM_ (p m) xs-  return m--maximVar, minimVar :: [Expr] -> Diagram Expr-maximVar = satAll (>==)-minimVar = satAll (<==)------------------- Expression constraints-(>==), (<==) :: Expr -> Expr -> Diagram ()-e1 <== e2 = do-  let LinExpr f c = e1 - e2-  leqTo f (negate c)--(>==) = flip (<==)--(===) :: Expr -> Expr -> Diagram ()-e1 === e2 = do-  let LinExpr f c = e1 - e2-  equalTo f (negate c)---- | minimize the distance between expressions-(=~=) :: Expr -> Expr -> Diagram ()-x =~= y = minimize =<< absoluteValue (x-y)------------------------------ Expression objectives--minimize,maximize :: Expr -> Diagram ()-minimize (LinExpr x _) = do-  tightness <- view diaTightness-  addObjective (tightness *- x)-maximize = minimize . negate--
− MarXup/Diagram/Object.hs 
@@ -1,266 +0,0 @@-{-# LANGUAGE DataKinds, KindSignatures, OverloadedStrings, EmptyDataDecls, MultiParamTypeClasses, FlexibleContexts, OverlappingInstances, TypeSynonymInstances, FlexibleInstances   #-}--module MarXup.Diagram.Object where---- import MarXup-import MarXup.Tex-import MarXup.Diagram.Tikz-import MarXup.Diagram.Path-import MarXup.Diagram.Point-import MarXup.Diagram.Layout-import MarXup.MultiRef (BoxSpec(..))-import Control.Monad-import Control.Applicative--- import Data.Algebra--- import Data.List (intersperse)-import Control.Lens (set)--data Anchor = Center | N | NW | W | SW | S | SE | E | NE | BaseW | Base | BaseE-  deriving Show---- | Box-shaped object. (a subtype)-type Box = Object--newtype Anchorage = Anchorage {boxAnchors :: Anchor -> Point}-data Object = Object {objectOutline :: Path, objectAnchorage :: Anchorage}--class Anchored a where-  anchors :: a -> Anchor -> Point-infix 8 #--(#) :: Anchored a => a -> Anchor -> Point-(#) = anchors--instance Anchored Anchorage where-  anchors = boxAnchors--instance Anchored Object where-  anchors = anchors . objectAnchorage--instance Anchored Point where-  anchors p _ = p---- | Horizontal distance between objects-hdist :: Anchored a => a -> a -> Expr-hdist x y = xpart (y # W - x # E)---- | Vertical distance between objects-vdist :: Anchored a => a -> a -> Expr-vdist x y = ypart (y # S - x # N)---- | Extend the box boundaries by the given delta-extend :: Expr -> Anchorage -> Anchorage-extend e o = Anchorage $ \a -> o # a + shiftInDir a e---- | Makes a shift of size 'd' in the given direction.-shiftInDir :: Anchor -> Expr -> Point-shiftInDir N d = 0 `Point` d-shiftInDir S d = 0 `Point` negate d-shiftInDir W d = negate d `Point` 0-shiftInDir E d  = d `Point` 0-shiftInDir NW d = negate d `Point` d-shiftInDir SE d = d `Point` negate d-shiftInDir SW d = negate d `Point` negate d-shiftInDir NE d = d `Point` d-shiftInDir _ _  = 0 `Point` 0---- | Make a label object. This is just some text surrounded by 4--- points of blank.-mkLabel :: TeX -> Diagram Anchorage-mkLabel texCode = extend 4 <$> texBox texCode--labelObj :: TeX -> Diagram Box-labelObj = rectangleShape <=< mkLabel---- | Label a point by a given TeX expression, at the given anchor.-labelPt :: TeX -> Anchor -> Point -> Diagram Box-labelPt labell anchor labeled  = do-  t <- labelObj labell -  t # anchor .=. labeled-  return t---- | A free point-point :: Diagram Point-point = do-  [x,y] <- newVars (replicate 2 ContVar)-  return $ Point x y---- | A point anchorage (similar to a box of zero width and height)-pointBox :: Diagram Anchorage-pointBox = do-  p <- point-  return $ Anchorage $ \a -> case a of _ -> p---- | A box. Anchors are aligned along a grid.-box :: Diagram Anchorage-box = do-  [n,s,e,w,base,midx,midy] <- newVars (replicate 7 ContVar)-  n >== base-  base >== s-  w <== e-  -  midx === avg [w,e]-  midy === avg [n,s]-  let pt = flip Point-  return $ Anchorage $ \anch -> case anch of-    NW     -> pt n    w-    N      -> pt n    midx-    NE     -> pt n    e  -    E      -> pt midy e-    SE     -> pt s    e-    S      -> pt s    midx-    SW     -> pt s    w-    W      -> pt midy w-    Center -> pt midy midx-    Base   -> pt base midx-    BaseE  -> pt base e-    BaseW  -> pt base w---- | A box of zero width-vrule :: Diagram Anchorage-vrule = do-  o <- box-  align xpart [o # W, o #Center, o#E]-  return o---- | A box of zero height-hrule :: Diagram Anchorage-hrule = do-  o <- box-  height o === 0-  return o--height o = ypart (o # N - o # S)-width o = xpart (o # E - o # W)-ascent o = ypart (o # N - o # Base)-descent o = ypart (o # Base - o # S)---- fitsVerticallyIn :: Anchorage -> Anchorage -> Diagram ()-o `fitsVerticallyIn` o' = do-  let dyN = ypart $ o' # N - o # N-      dyS = ypart $ o # S - o' # S-  minimize dyN-  dyN >== 0-  minimize dyS-  dyS >== 0---- fitsHorizontallyIn :: Anchorage -> Anchorage -> Diagram ()-o `fitsHorizontallyIn` o' = do-  let dyW = xpart $ o # W - o' # W-      dyE = xpart $ o' # E - o # E-  minimize dyW-  dyW >== 0-  minimize dyE-  dyE >== 0--a `fitsIn` b = do-  a `fitsHorizontallyIn` b-  a `fitsVerticallyIn` b--circleShape :: Diagram Object-circleShape = do-  anch <- box-  width anch === height anch-  let radius = 0.5 *- width anch-  let p = circle (anch # Center) radius-  path p-  return $ Object p anch---   let k1 :: Constant---       k1 = sqrt 2 / 2---       k = k1 *^ r---       p = circle center r---   return $ Object p $ Anchorage $ \a -> center + case a of---     N -> Point 0 r---     S -> Point 0 (-r)---     E -> Point r 0---     W -> Point (-r) 0---     Center -> Point 0 0---     NE -> Point k k--rectangleShape :: Anchorage -> Diagram Object-rectangleShape l = do-  let p = polygon (map (l #) [NW,NE,SE,SW])-  path p-  return $ Object p l--traceAnchorage :: Anchored a => Color -> a -> Diagram ()-traceAnchorage c l = do-  stroke c $ path $ polygon (map (l #) [NW,NE,SE,SW])-  -- TODO: draw the baseline, etc.---- | Typeset a piece of text and return its bounding box.-texBox :: TeX -> Diagram Anchorage-texBox t = do-  l <- box-  -- traceAnchorage "red" l-  BoxSpec wid h desc <- drawText (l # NW) t--  width   l === constant wid-  descent l === constant desc-  height  l === constant (h + desc)-  return l--data Incidence = Incidence { incidencePoint, incidenceNormal :: Point }-swap :: Incidence -> Incidence-swap (Incidence p v) = Incidence p (negate v)---- | Traces a straight edge between two objects.--- The midpoint is returned, as well as a normal vector.-edge :: Object -> Object -> Diagram Incidence-edge source target = do-  let points@[a,b] = [source # Center,target # Center]-      link = polyline points-      targetArea = objectOutline target-      sourceArea = objectOutline source-  l' <- freeze link-  sa' <- freeze sourceArea-  ta' <- freeze targetArea-  frozenPath $ (l' `cutAfter` ta') `cutBefore` sa'-  return $ Incidence (avg points) (rotate90 (b-a))--(.<.) :: Point -> Point -> Diagram ()-Point x1 y1 .<. Point x2 y2 = do-  x1 <== x2-  y1 <== y2---- | Forces the point to be inside the (bounding box) of the object.-inside :: Point -> Box -> Diagram ()-inside p o = do-  (o # SW) .<. p-  p .<. (o # NE)---- | @autoLabel label i@ Layouts the label at the given incidence--- point.-autoLabel :: Box -> Incidence -> Diagram ()-autoLabel lab (Incidence pt norm) = do-  pt `inside` lab-  minimize =<< orthoDist (lab#Center) (pt + norm)---- | @labeledEdge label source target@-labeledEdge :: Object -> Object -> Box -> Diagram ()-labeledEdge source target lab = autoLabel lab =<< edge source target-------------------------- Even higher-level primitives:-----example:      spread hdist 30 ps--spread f d (x:y:xs) = do-  f x y === d-  spread f d (y:xs)-spread f _ _ = return ()--node lab = do-  l <- extend 4 <$> texBox lab-  c <- draw $ circleShape-  l `fitsIn` c-  l # Center .=. c # Center-  return c--arrow :: Object -> Object -> Diagram Incidence-arrow src trg = using (outline "black" . set endTip LatexTip) $ do-  edge src trg-
− MarXup/Diagram/Path.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}--module MarXup.Diagram.Path where--import MarXup.Diagram.Layout-import MarXup.Diagram.Point-import Data.Traversable-import Data.Foldable-import Data.Algebra--- import Data.Traversable--- import Data.Foldable-import Graphics.Typography.Geometry.Bezier-import Graphics.Typography.Geometry.Bezier as MarXup.Diagram.Point (Curve) -import Control.Applicative-import Data.List (sort,transpose)-import Data.Maybe (listToMaybe)-import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum)-import qualified Data.Vector.Unboxed as V-import Algebra.Polynomials.Bernstein (restriction,Bernsteinp(..))--type Frozen x = x Constant-type FrozenPoint = Frozen Point'-type FrozenPath = Frozen Path'--freeze :: Traversable t => t Expr -> Diagram (t Constant)-freeze = traverse valueOf--unfreeze :: Functor t => t Constant -> t Expr-unfreeze = fmap constant--toBeziers :: FrozenPath -> [Curve]-toBeziers EmptyPath = []-toBeziers (Path start ss) | not (null ss) &&-                            isCycle (last ss) = toBeziers' start (init ss ++ [StraightTo start])-                          | otherwise = toBeziers' start ss--curveSegment (Point xa ya) (Point xb yb) (Point xc yc) (Point xd yd) = bezier3 xa ya xb yb xc yc xd yd-lineSegment (Point xa ya) (Point xb yb) = line xa ya xb yb--toBeziers' :: FrozenPoint -> [Frozen Segment] -> [Curve]-toBeziers' _ [] = []-toBeziers' start (StraightTo next:ss) = curveSegment start mid mid next : toBeziers' next ss-  where mid = avg [start, next]-toBeziers' p (CurveTo c d q:ss) = curveSegment p c d q : toBeziers' q ss--fromBeziers :: [Curve] -> FrozenPath-fromBeziers [] = EmptyPath-fromBeziers (Bezier cx cy t0 t1:bs) = case map toPt $ V.foldr (:) [] cxy of-      [p,c,d,q] -> Path p (CurveTo c d q:rest)-      [p,q] -> Path p (StraightTo q:rest)-  where [cx',cy'] = map (\c -> coefs $ restriction c t0 t1) [cx,cy]-        cxy = V.zip cx' cy'-        toPt (x,y) = Point x y-        rest = pathSegments (fromBeziers bs)--pathSegments :: Path' t -> [Segment t]-pathSegments EmptyPath = []-pathSegments (Path _ ss) = ss--isCycle Cycle = True-isCycle _  = False--frozenPointElim (Point x y) f = f x y--splitBezier (Bezier cx cy t0 t1) (u,v,_,_) = (Bezier cx cy t0 u, Bezier cx cy v t1)--clipOne :: Curve -> [Curve] -> Maybe Curve-clipOne b cutter = fmap firstPart $ listToMaybe $ sort $ concatMap (inter b) cutter-  where firstPart t = fst $ splitBezier b t---- | @cutAfter path area@ cuts the path after its first intersection with the @area@.-cutAfter', cutBefore' :: [Curve] -> [Curve] -> [Curve]-cutAfter' [] _cutter = []-cutAfter' (b:bs) cutter = case clipOne b cutter of-  Nothing -> b:cutAfter' bs cutter-  Just b' -> [b']--revBernstein (Bernsteinp n c) = Bernsteinp n (V.reverse c)-revBeziers :: [Curve] -> [Curve]-revBeziers = reverse . map rev-  where rev (Bezier cx cy t0 t1) = (Bezier (revBernstein cx) (revBernstein cy) (1-t1) (1-t0))--cutBefore' path area = revBeziers $ cutAfter' (revBeziers path) area--onBeziers :: ([Curve] -> [Curve] -> [Curve])-             -> FrozenPath -> FrozenPath -> FrozenPath-onBeziers op p' q' = fromBeziers $ op (toBeziers p') (toBeziers q')---cutAfter :: FrozenPath -> FrozenPath -> FrozenPath-cutAfter = onBeziers cutAfter'--cutBefore :: FrozenPath -> FrozenPath -> FrozenPath-cutBefore = onBeziers cutBefore'--data Segment v = CurveTo (Point' v) (Point' v) (Point' v)-                   | StraightTo (Point' v)-                   | Cycle-                   -- | Rounded (Maybe Constant)-                   -- | HV point | VH point-  deriving (Show,Eq)-instance Functor Segment where-  fmap = fmapDefault-  -instance Foldable Segment where-  foldMap = foldMapDefault-instance Traversable Segment where-  traverse _ Cycle = pure Cycle-  traverse f (StraightTo p) = StraightTo <$> traverse f p-  traverse f (CurveTo c d q) = CurveTo <$> traverse f c <*> traverse f d <*> traverse f q-  ---------------------- Paths--type Path = Path' Expr--data Path' a-  = EmptyPath-  | Path {startingPoint :: Point' a-         ,segments :: [Segment a]}-  deriving Show---- mapPoints :: (Point' a -> Point' b) -> Path' a -> Path' b-instance Functor Path' where-  fmap = fmapDefault--instance Foldable Path' where-  foldMap = foldMapDefault-instance Traversable Path' where-  traverse _ EmptyPath = pure EmptyPath-  traverse f (Path s ss) = Path <$> traverse f s <*> traverse (traverse f) ss---polyline :: [Point] -> Path-polyline [] = EmptyPath-polyline (x:xs) = Path x (map StraightTo xs)--polygon :: [Point] -> Path-polygon [] = EmptyPath-polygon (x:xs) = Path x (map StraightTo xs ++ [Cycle])----- | Circle approximated with 4 cubic bezier curves-circle :: Point -> Expr -> Path-circle center r =      Path (pt r 0)-                         [CurveTo (pt r k) (pt k r) (pt 0 r),-                          CurveTo (pt (-k) r) (pt (-r) k) (pt (-r) 0),-                          CurveTo (pt (-r) (-k)) (pt (-k) (-r)) (pt 0 (-r)),-                          CurveTo (pt k (-r)) (pt r (-k)) (pt r 0),-                          Cycle]- where k1 :: Constant-       k1 = 4 * (sqrt 2 - 1) / 3-       k = k1 *^ r-       pt x y = center ^+^ (Point x y)-
− MarXup/Diagram/Point.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}--module MarXup.Diagram.Point where--import MarXup.Diagram.Layout-import Data.Traversable-import Data.Foldable-import Data.Algebra-import Control.Applicative-import Data.List (transpose)-import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum)--infix 4 .=.-------------------- Points --- | A point in 2d space-data Point' a = Point {xpart :: a, ypart :: a}-  deriving (Eq,Show)--instance Traversable Point' where-  traverse f (Point x y) = Point <$> f x <*> f y--instance Foldable Point' where-  foldMap = foldMapDefault--instance Functor Point' where-  fmap = fmapDefault--  -type Point = Point' Expr-instance Group a => Num (Point' a) where-  negate = neg-  (+) = (^+^)-  (-) = (^-^)--instance Group v => Group (Point' v) where-  zero = Point zero zero-  Point x1 y1 ^+^ Point x2 y2 = Point (x1 ^+^ x2) (y1 ^+^ y2)-  neg (Point x y) = Point (neg x) (neg y)--instance Module Constant v => Module Constant (Point' v) where-  k *^ Point x y = Point (k *^ x) (k *^ y)---- | Orthogonal norm of a vector-orthonorm :: Point -> Diagram Expr-orthonorm (Point x y) =-  (+) <$> absoluteValue x <*> absoluteValue y---- | Orthogonal distance between points.-orthoDist :: Point -> Point -> Diagram Expr-orthoDist p q = orthonorm (q-p)---- | Rotate a vector 90 degres in the trigonometric direction.-rotate90, rotate180 :: Point -> Point-rotate90 (Point x y) = Point (negate y) x--rotate180 = rotate90 . rotate90--xdiff,ydiff :: Point -> Point -> Expr-xdiff p q = xpart (q - p)-ydiff p q = ypart (q - p)---------------------- Point constraints--(.=.),northOf,southOf,westOf,eastOf :: Point -> Point -> Diagram ()-Point x1 y1 .=. Point x2 y2 = do-  x1 === x2-  y1 === y2--northOf (Point _ y1) (Point _ y2) = y2 <== y1-southOf = flip northOf-westOf (Point x1 _) (Point x2 _) = x1 <== x2-eastOf = flip westOf--alignHoriz,alignVert :: [Point] -> Diagram ()-alignHoriz = align ypart-alignVert = align xpart--align :: (a -> Expr) -> [a] -> Diagram ()-align _ [] = return ()-align f (p:ps) = forM_ ps $ \p' -> f p === f p'--alignMatrix :: [[Point]] -> Dia-alignMatrix ls = do-  forM_ ls alignHoriz-  forM_ (transpose ls) alignVert-------------------------- Point objectives--southwards, northwards, westwards, eastwards :: Point -> Diagram ()-southwards (Point _ y) = minimize y-westwards (Point x _) = minimize x-northwards = southwards . negate-eastwards = westwards . negate
MarXup/Diagram/Tikz.hs view
@@ -1,145 +1,67 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell, RankNTypes #-}  module MarXup.Diagram.Tikz where -import MarXup.Diagram.Layout-import MarXup.Diagram.Point-import MarXup.Diagram.Path-import Control.Lens hiding (element)+import Graphics.Diagrams.Core+import Graphics.Diagrams.Path import Prelude hiding (sum,mapM_,mapM,concatMap)-import Control.Applicative import Data.List (intercalate)-import Data.String import MarXup-import MarXup.MultiRef+import MarXup.MultiRef (newLabel) import MarXup.Tex import Numeric (showFFloat)-import Data.Traversable import Data.Foldable import Data.Monoid-import Control.Monad.Reader -instance Element Expr where-  type Target Expr = Dia-  element x = do-    v <- valueOf x-    diaRaw $ showDistance v+type TexDiagram = Diagram TeX Tex -instance Element (Diagram ()) where-  type Target (Diagram ()) = TeX+instance Element (Diagram TeX Tex ()) where+  type Target (Diagram TeX Tex ()) = TeX   element d = do    texLn "" -- otherwise beamer does not understand where a tikzpicture ends (?!!)    braces $ do-    cmd0 "normalsize"-      -- otherwise the boxes use "normalsize", while tikz inherits-      -- the smaller or bigger size from the current scope. Actually,-      -- every text styling should be reset, but I don't know how to-      -- do that.+    usepkg "tikz" 100 []     env "tikzpicture" $-      Tex $ runDiagram d------------------------- Point rendering-instance Element Point where-  type Target Point = Diagram ()-  element (Point x y) = "(" <> element x <> "," <> element y <> ")"--diaDebug msg = diaRaw $ "\n%DBG:" ++ msg ++ "\n"--instance (Element (Point' v),Monoid (Target (Point' v)), IsString (Target (Point' v))) => Element (Segment v) where-  type Target (Segment v) = Target (Point' v)-  element (StraightTo p) = "--" <> element p-  element (CurveTo c d p) = "..controls" <> element c <> "and" <> element d <> ".." <> element p-  element Cycle = "--cycle"-  -- element (VH p) = "|-" <> element p-  -- element (HV p) = "-|" <> element p-  -- element (Rounded Nothing) = "[sharp corners]"-  -- element (Rounded (Just r)) = "[" <> element (constant r) <> "]"--instance Element Path where-  type Target Path = Diagram ()-  element = path+      runDiagram tikzBackend d -path :: Path -> Dia-path = frozenPath <=< freeze+-- diaDebug msg = diaRaw $ "\n%DBG:" ++ msg ++ "\n"+class Tikz a where+  toTikz :: a -> String -frozenPath :: FrozenPath  -> Dia-frozenPath p  = do-  options <- view diaPathOptions-  diaRaw $ "\\path"-    <> element options-    <> case p of-      EmptyPath -> ""-      (Path start segs) -> element start ++ concatMap element segs-  diaRaw ";\n"+instance Tikz FrozenPoint where+  toTikz (Point x y) =  "(" <> showDistance x <> "," <> showDistance y <> ")" +instance Tikz (Frozen Segment) where+  toTikz (StraightTo p) = "--" <> toTikz p+  toTikz (CurveTo c d p) = "..controls" <> toTikz c <> "and" <> toTikz d <> ".." <> toTikz p+  toTikz Cycle = "--cycle"+  -- toTikz (VH p) = "|-" <> toTikz p+  -- toTikz (HV p) = "-|" <> toTikz p+  -- toTikz (Rounded Nothing) = "[sharp corners]"+  -- toTikz (Rounded (Just r)) = "[" <> toTikz (constant r) <> "]"  showDistance :: Constant -> String showDistance x = showFFloat (Just 4) x tikzUnit     where tikzUnit = "pt" -instance Element FrozenPoint where-  type Target FrozenPoint = String-  element pt = frozenPointElim pt $ \x y -> "(" <> showDistance x <> "," <> showDistance y <> ")"----------------------- Path Options--localPathOptions :: (PathOptions -> PathOptions) -> Diagram a -> Diagram a-localPathOptions f = local (over diaPathOptions f)--instance Show LineTip where-  show t = case t of+instance Tikz LineTip where+  toTikz t = case t of     ToTip -> "to"     StealthTip -> "stealth"     CircleTip -> "o"     NoTip -> ""     LatexTip -> "latex"-    ReversedTip x -> show x ++ " reversed"+    ReversedTip x -> toTikz x ++ " reversed"     BracketTip -> "["     ParensTip -> "(" --ultraThin, veryThin, thin, semiThick, thick, veryThick, ultraThick :: Constant-ultraThin = 0.1-veryThin = 0.2-thin = 0.4-semiThick = 0.6-thick = 0.8-veryThick = 1.2-ultraThick = 1.6-- showDashPat :: DashPattern -> String showDashPat xs = intercalate " " ["on " <> showDistance on <>                                   " off " <> showDistance off | (on,off) <- xs] -solid             o@PathOptions{..} = o { _dashPattern = [] }-dotted            o@PathOptions{..} = o { _dashPattern = [(_lineWidth,2)] }-denselyDotted     o@PathOptions{..} = o { _dashPattern = [(_lineWidth, 1)] }-looselyDotted     o@PathOptions{..} = o { _dashPattern = [(_lineWidth, 4)] }-dashed            o@PathOptions{..} = o { _dashPattern = [(3, 3)] }-denselyDashed     o@PathOptions{..} = o { _dashPattern = [(3, 2)] }-looselyDashed     o@PathOptions{..} = o { _dashPattern = [(3, 6)] }-dashdotted        o@PathOptions{..} = o { _dashPattern = [(3, 2), (_lineWidth, 2)] }-denselyDashdotted o@PathOptions{..} = o { _dashPattern = [(3, 1), (_lineWidth, 1)] }-looselyDashdotted o@PathOptions{..} = o { _dashPattern = [(3, 4), (_lineWidth, 4)] }--using = localPathOptions-stroke color = using (outline color)-draw = stroke "black"--noOutline = set drawColor Nothing-outline color = set drawColor (Just color)-fill color = set fillColor (Just color)--zigzagDecoration = set decoration (Decoration "zigzag")--instance Element PathOptions where-  type Target PathOptions = String-  element PathOptions{..} = "["-    <> show _startTip <> "-" <> show _endTip <> ","+instance Tikz PathOptions where+  toTikz PathOptions{..} = "["+    <> toTikz _startTip <> "-" <> toTikz _endTip <> ","     <> col "draw" _drawColor     <> col "fill" _fillColor     <> "line width=" <> showDistance _lineWidth <> ","@@ -158,15 +80,28 @@     <> "]"     where col attr = maybe "" (\c -> attr <> "=" <> c <> ",") -------------- Text--drawText :: Point -> TeX -> Diagram BoxSpec-drawText point t = do-  diaRawTex $ tex $ "\\node[anchor=north west,inner sep=0] at "-  element point-  (_,box) <- diaRawTex $ inBox $ braces $ t-  diaRawTex $ tex ";\n"-  return box+tikzBackend :: Backend TeX Tex+tikzBackend = Backend {..} where+  _tracePath options p = do+     tex $ "\\path"+       <> toTikz options+       <> case p of+         EmptyPath -> ""+         (Path start segs) -> toTikz start ++ concatMap toTikz segs+     tex ";\n"+  _traceLabel :: Monad x =>+                   (location -> (FrozenPoint -> Tex ()) -> x ()) -> -- freezer+                   (forall a. Tex a -> x a) -> -- embedder+                   location ->+                   Tex () -> -- label specification+                   x BoxSpec+  _traceLabel freezer embedder point lab = do+       bxId <- embedder $ Tex newLabel+       freezer point $ \p' -> do+         tex $ "\\node[anchor=north west,inner sep=0] at " ++ toTikz p'+         fillBox bxId True $ braces $ lab+         tex ";\n"+       embedder $ getBoxFromId bxId  +type Dia = TexDiagram ()
MarXup/Latex.hs view
@@ -3,14 +3,12 @@  import MarXup import MarXup.Verbatim-import Control.Monad (forM_)+import Control.Monad (forM_,when,forM) import MarXup.Tex-import Data.List (intersperse,groupBy,elemIndex,nub)+import Data.List (intersperse,groupBy,elemIndex,nub,intercalate) import Data.Monoid-import Control.Applicative import Data.Function (on) - -- | Separate the arguments with '\\' mkrows,mkcols :: [TeX] -> TeX mkrows ls = sequence_ $ intersperse newline ls@@ -19,35 +17,37 @@ mkcols = sequence_ . intersperse newcol  vspace, hspace :: String -> TeX-vspace = cmd "vspace" . textual-hspace = cmd "hspace" . textual+vspace = cmd "vspace" . tex+hspace = cmd "hspace" . tex++hfill :: TeX hfill = cmd0 "hfill"  title :: TeX -> TeX title = cmd "title" --data ClassFile = Plain | LNCS | SIGPlan | IEEE | EPTCS | Beamer-  deriving Eq type AuthorInfoStyle = ClassFile  data AuthorInfo = AuthorInfo {authorName :: String, authorEmail :: String, authorInst :: String} --- | author info in as triplets name, institution, email-authorinfo :: AuthorInfoStyle -> [AuthorInfo] -> TeX-authorinfo LNCS as = do+authorinfo :: [AuthorInfo] -> Tex ()+authorinfo as = do c<-askClass; authorinfo' c as++-- | author info as triplets name, institution, email+authorinfo' :: AuthorInfoStyle -> [AuthorInfo] -> TeX+authorinfo' LNCS as = do   cmd "author" $ mconcat $ intersperse (cmd0 "and") $ map oneauthor as   cmd "institute" $ mconcat $ intersperse (cmd0 "and") $ map textual $ insts   where oneauthor AuthorInfo{..} = textual authorName <> (if length insts > 1 then cmd "inst" (textual $ show $ 1 + instIdx) else mempty)            where Just instIdx = elemIndex authorInst insts         insts = nub $ map authorInst as -authorinfo SIGPlan as = forM_ (groupBy ((==) `on` authorInst) as) $ \ (g@((AuthorInfo _ _ institution):_)) -> do+authorinfo' SIGPlan as = forM_ (groupBy ((==) `on` authorInst) as) $ \ (g@((AuthorInfo _ _ institution):_)) -> do     let names = map authorName g         emails = mconcat $ intersperse (cmd0 "and") $ map (textual . authorEmail) g     cmdn "authorinfo" [mconcat $ intersperse (cmd0 "and") $ map textual names, textual institution, emails]     return ()-authorinfo EPTCS as = mconcat $ intersperse and' $+authorinfo' EPTCS as = mconcat $ intersperse and' $   flip map (groupBy ((==) `on` authorInst) as) $ \ (g@((AuthorInfo _ _ institution):_)) -> do     cmd "author" $ do       mconcat $ intersperse dquad $ map (textual . authorName) g@@ -56,28 +56,59 @@     return ()   where dquad = cmd0 "quad" <> cmd0 "quad"         and' = cmd0 "and"-authorinfo IEEE as = cmd "author" $ do+authorinfo' Beamer as = do+  cmd "author" $ mconcat $ intersperse (cmd0 "and") $ flip map as $ \a -> do+      textual $ authorName a+      case elemIndex (authorInst a) institutions of+        Nothing -> textual $ "error: could not find " ++ (authorInst a)+        Just idx -> inst idx+      -- No emails in beamer+  cmd "institute" $+      forM_ (zip institutions [0..]) $ \(i,idx) -> do+        inst idx+        textual i+  return ()+  where institutions = nub $ map authorInst $ as+        inst :: Int -> TeX+        inst i = when (length institutions > 1) $ cmd "inst" $ tex $ show (i+1)++authorinfo' IEEE as = cmd "author" $ do   cmd "IEEEauthorblockN" $ mconcat $ intersperse (hspace "1cm") $ map (textual . authorName) as   tex "\n\n" -- for some reason the IEEE class wants a paragraph separation here.   cmd "IEEEauthorblockA" $ mkrows $ [textual inst,"email: " <> textual (mconcat $ intersperse " " $ map authorEmail as)]   where (AuthorInfo {authorInst = inst}:_) = as-authorinfo _ {- Plain, EPTCS, Beamer -} as = cmd "author" $ mconcat $ intersperse (cmd0 "and") $ map oneauthor as+authorinfo' _ {- Plain -} as = cmd "author" $ mconcat $ intersperse (cmd0 "and") $ map oneauthor as   where oneauthor (AuthorInfo name _ institution) = textual name <> newline <> textual institution -keywords :: ClassFile -> [String] -> TeX-keywords LNCS ks = do-  cmd "keywords" $ mconcat $ intersperse ", " $ map textual ks-keywords IEEE ks = env "IEEEkeywords" $ do-  mconcat $ intersperse ", " $ map textual ks-keywords SIGPlan ks = do-  cmd0 "keywords"-  mconcat $ intersperse ", " $ map textual ks-keywords _ _ = return ()+keywords :: [String] -> TeX+keywords ks = do+  classFile <- askClass+  case classFile of+    Plain -> do+      paragraph "keywords"+      mconcat $ intersperse ", " $ map textual ks+      return ()+    LNCS -> do cmd "keywords" $ mconcat $ intersperse ", " $ map textual ks+    IEEE -> env "IEEEkeywords" $ do mconcat $ intersperse ", " $ map textual ks+    SIGPlan -> do cmd0 "keywords"+                  mconcat $ intersperse ", " $ map textual ks+    _ -> return () +acknowledgements :: Tex a -> Tex a+acknowledgements body = do+  classFile <- askClass+  case classFile of+    SIGPlan -> cmd0 "acks" >> body+    _ -> do paragraph "acknowledgements"+            body ++newline :: TeX newline = backslash <> backslash+newcol :: TeX newcol = tex "&"-newpara = texLines ["",""]+newpara :: Tex ()+newpara = texLn "\\par"  maketitle :: Tex () maketitle = cmd "maketitle" $ return ()@@ -86,7 +117,7 @@ ldots = cmd "ldots" (return ())  -- | Sectioning-section,subsection,paragraph :: TeX -> Tex SortedLabel+section,subsection,subsubsection,paragraph :: TeX -> Tex SortedLabel section s = cmd "section" s >> label "Sec." subsection s = cmd "subsection" s >> label "Sec." subsubsection s = cmd "subsubsection" s >> label "Sec."@@ -107,19 +138,45 @@ stdPreamble :: TeX stdPreamble = do   usepackage "graphicx" []+  usepackage "ifxetex" []+  cmd0 "ifxetex"+  usepackage "fontspec" []+  usepackage "newunicodechar" []+  mapM_ texLn ["\\newcommand{\\DeclareUnicodeCharacter}[2]{%"+              ,"\\begingroup\\lccode`|=\\string\"#1\\relax"+              ,"\\lowercase{\\endgroup\\newunicodechar{|}}{#2}%"+              ,"}"]+  cmd0 "else"   usepackage "inputenc" ["utf8"]+  cmd0 "fi"   return () -documentClass :: String -> [String] -> TeX-documentClass docClass options = cmd' "documentclass" options (tex docClass)- ---------- -- Lists +{-# DEPRECATED item, enumerate, itemize "Since Aug 2015. Use itemList, enumList, descList instead "#-} item = cmd0 "item" enumerate = env "enumerate" itemize = env "itemize" +itemList :: [TeX] -> TeX+itemList [] = mempty+itemList xs = env "itemize" $ forM_ xs $ \x -> do+  cmd0 "item"+  x++enumList :: [TeX] -> TeX+enumList [] = mempty+enumList xs = env "enumerate" $ forM_ xs $ \x -> do+  cmd0 "item"+  x++descList :: [(TeX,TeX)] -> TeX+descList [] = mempty+descList xs = env "enumerate" $ forM_ xs $ \(lab,x) -> do+  cmdm "item" [lab] []+  x+ ------------------------ -- Various environments @@ -231,5 +288,4 @@         opt' = tex $ mconcat . intersperse ", "                $ "basicstyle=\\ttfamily" :  opt in     backslash <> "lstinline" <> brackets opt' <> sep <> tex s <> sep-
MarXup/Latex/Math.hs view
@@ -5,9 +5,9 @@ import MarXup.Tex import MarXup import Data.Monoid-import Data.Ratio import Control.Monad (unless) +align :: [[TeX]] -> Tex () align  = env "align*" . mkrows . map mkcols  array :: [String] -> String -> [[TeX]] -> TeX@@ -30,7 +30,9 @@ mbox = cmd "mbox" fbox :: TeX -> TeX fbox = cmd "fbox"+superscript :: Tex () -> TeX superscript y = tex "^" <> braces y+subscript :: Tex () -> TeX subscript x = tex "_" <> braces x  displayMath = env "displaymath"@@ -38,60 +40,65 @@ mathsf :: Tex a -> Tex a mathsf = cmd "mathsf" -mathpreamble :: ClassFile -> TeX-mathpreamble sty = do-  usepackage "graphicx" []+mathpreamble :: TeX+mathpreamble = do   usepackage "amsmath"  []-  unless (sty == LNCS) $ usepackage "amsthm"   []   usepackage "amssymb"  []   -- extra symbols such as □   usepackage "stmaryrd" [] -- has ⟦ and ⟧-  usepackage "mathpartir" [] -- mathpar environment -  unless (sty == LNCS || sty == Beamer) $ do-    newtheorem "theorem" "Theorem"-    newtheorem "corollary" "Corollary"-    newtheorem "lemma" "Lemma"-    newtheorem "definition" "Definition"-    newtheorem "proposition" "Proposition"  mathpar :: [[TeX]] -> TeX-mathpar = env "mathpar" . mkrows . map mk . filter (not . null)- where mk = foldr1 (\x y -> x <> cmd0 "and" <> y)+mathpar ps = do+   usepkg "mathpartir" 100 []+   env "mathpar" . mkrows . map mk . filter (not . null) $ ps+  where mk = foldr1 (\x y -> x <> cmd0 "and" <> y) +mathbox :: Tex a -> Tex a mathbox = mbox . ensureMath -newtheorem :: String -> TeX -> TeX-newtheorem ident txt = cmd "newtheorem" (tex ident) >> braces txt -deflike :: String -> String -> TeX -> TeX -> Tex SortedLabel-deflike reference nv name statement = env'' nv [] [name] $ do-  statement-  label reference+-- | @deflike referent nv header name statement@:+-- Environement of name @nv@, which should be refered as @referent@.+deflike :: String -> String -> String -> TeX -> TeX -> Tex SortedLabel+deflike referent nv header name statement = do+  newtheorem nv header+  cls <- askClass+  unless (cls == LNCS) $ usepkg "amsthm" 100 []+  let envir body = case cls of+        SIGPlan -> env'' nv [name] [] (hspace "0cm" >> body)+        _ -> env'' nv [] [name] body+  envir $ do+    statement+    label referent -thmlike :: String -> String -> TeX -> TeX -> TeX -> Tex SortedLabel-thmlike reference nv name statement proof = do-  x <- deflike reference nv name statement+thmlike :: String -> String -> String -> TeX -> TeX -> TeX -> Tex SortedLabel+thmlike referent nv header name statement proof = do+  x <- deflike referent nv header name statement   env "proof" proof   return x  theorem,lemma ::  TeX -> TeX -> TeX -> Tex SortedLabel-theorem = thmlike "Thm." "theorem"-lemma = thmlike "Lem." "lemma"+theorem = thmlike "Thm." "theorem" "Theorem"+lemma = thmlike "Lem." "lemma" "Lemma" -definition,corollary :: TeX -> TeX -> Tex SortedLabel-definition = deflike "Def." "definition"-corollary = deflike "Cor." "corollary"-proposition = deflike "Prop." "proposition"-example = deflike "Ex." "example"+definition,corollary,proposition,example :: TeX -> TeX -> Tex SortedLabel+definition = deflike "Def." "definition" "Definition"+corollary = deflike "Cor." "corollary" "Corollary"+proposition = deflike "Prop." "proposition" "Proposition"+example = deflike "Ex." "example" "Example"  -- Other stuff oxford :: Tex a -> Tex a oxford = bigParenthesize (textual "⟦") (textual "⟧") +multiline' :: [TeX] -> Tex () multiline' body = env "multline*" $ mkrows body +frac :: TeX -> TeX -> Tex () frac x y = cmdn_ "frac" [x,y] +centerVertically :: Tex a -> Tex a centerVertically = ensureMath . cmd "vcenter" . cmd "hbox" +qedhere :: Tex () qedhere = cmd0 "qedhere"
+ MarXup/LineUp.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE RecordWildCards #-}+module MarXup.LineUp (Tok(..),lineup,mkSpaces) where++import Data.List+import Data.Foldable+import Control.Monad (when)+import Data.Monoid+import Data.Maybe (catMaybes)++import MarXup.Tex++data Tok = Tok {+  startCol :: Int,+  endCol :: Int,+  preSpace :: Float, -- max amount of space which should come before this token, in mu+  render :: TeX,+  postSpace :: Float -- max amount of space which should come after this token, in mu+  }+++justIf True x = Just x+justIf _ _ = Nothing++marx True = '!'+marx False = '-'++lineup :: [[Tok]] -> TeX+lineup input = env'' "list" [] [mempty,tex "\\setlength\\leftmargin{1em}"] $ do+  usepkg "polytable" 100 []+  texLn ""+  texLines $ map (("% " ++) . map marx . drop 1 . isIndentTab ) array+  +  texLn "\\item\\relax"+  cmd "ensuremath" $ env "pboxed" $ do+    declColumn Nothing "B"+    forM_ (zip3 allTabStops [(1::Int)..] (drop 1 indentColumns)) $ \(_col,tab,indenting) -> +      declColumn (justIf (indenting) $ tex $ show (tab-1) ++ "em") (show tab)+    declColumn Nothing "E"+    texLn "%"+    sequence_ $ intersperse (texLn "\\\\") $ map printLine array+  where+    showCol 0 = "B"+    showCol n = show n+    declColumn :: Maybe TeX -> String -> TeX+    declColumn dim c = do+      cmdm "column" (catMaybes [dim]) [tex c,tex "@{}>{}l<{}@{}"]+      return ()++    printLine :: [[Tok]] -> TeX+    printLine xs = do+      forM_ (zip xs [(0::Int)..]) $ \(ts,colName) -> do+         when (not $ null ts) $ do+           cmdn' ">" [showCol colName] []+           braces $ forM_ ts $ \t -> do +                render t+      cmdn' "<" ["E"] []+      return ()++    -- The input, grouped in lines and columns+    array :: [[[Tok]]]+    array = map (tabify . mkSpaces) input++    -- Is the token preceded by two spaces or starts a line?+    isAligning :: [Tok] -> [(Bool,Tok)]+    isAligning [] = []+    isAligning (x:xs) = (True,x) :+                        [(startCol t2 > 1 + endCol t1,t2) | (t1,t2) <- zip (x:xs) xs]++    -- | The tabstop possibly beginning an indentation? It cannot be+    -- if it both contains a token and is preceded by stuff.+    isIndentTab :: [[Tok]] -> [Bool]+    isIndentTab xs = zipWith (||) nulls (scanl (&&) True nulls) +      where nulls = map null xs++    -- | Is a tabstop an indentation? (Take the intersection for all lines)+    indentColumns :: [Bool]+    indentColumns = map and $ transpose $ map isIndentTab array++    -- The tab stops in a line+    tabStops :: [Tok] -> [Int]+    tabStops xs = [startCol x | (align,x) <- isAligning xs, align]++    -- all the tab stops+    allTabStops :: [Int]+    allTabStops = sort $ nub $ concatMap tabStops input++    tabify :: [Tok] -> [[Tok]]+    tabify xs = tabify' (isAligning xs) allTabStops++    clearMeta :: [(Bool,Tok)] -> [Tok]+    clearMeta = map snd++    tabify' :: [(Bool,Tok)] -> [Int]-> [[Tok]]+    tabify' [] _ = []+    tabify' xs [] = [clearMeta xs]+    tabify' xs (t:ts) = clearMeta col:tabify' xs' ts+      where (col,xs') = break (\(align,s) -> align && (startCol s >= t)) xs++++--- | Transform a list of tokens to move the spacing info into the TeX+-- field of the tokens (spacing goes after the texts)+mkSpaces :: [Tok] -> [Tok]+mkSpaces [] = []+-- mkSpaces ts = [ Tok startCol endCol+--                 0 (tex (show preSpace) <> render <> tex (show postSpace) <> tex "\\;") 0+--               | Tok{..} <- ts]+mkSpaces ts = [ Tok (startCol l) (endCol l) 0+                (render l <>+                 tex ("\\mskip " ++ show (min (postSpace l) (preSpace r)) ++ "mu" )) 0+              | (l,r) <- zip ts (tail ts) ] ++ [last ts]
+ MarXup/LineUp/Haskell.hs view
@@ -0,0 +1,217 @@+module MarXup.LineUp.Haskell where++import Data.List+import Data.Function+import Language.Haskell.Exts.Lexer+import Language.Haskell.Exts.Parser (ParseResult(..),ParseMode(..),defaultParseMode)+import Language.Haskell.Exts.SrcLoc+import MarXup+import MarXup.LineUp+import MarXup.Tex+import MarXup.Verbatim+import Data.Monoid+import Data.Char (isDigit)++haskell :: Verbatim a -> Tex ()+haskell = haskellCust defaultParseMode printTok++haskellInline :: Verbatim a -> Tex ()+haskellInline = haskellInlineCust defaultParseMode printTok++type PrintTok = Token -> (Float,TeX,Float)++haskellInlineCust :: ParseMode -> (PrintTok) -> Verbatim a -> Tex ()+haskellInlineCust mode custPrintTok v = case lexTokenStreamWithMode mode (fromVerbatim v) of+   ParseOk toks -> mconcat $ map render $ mkSpaces $ map (mkTok custPrintTok) toks+   ParseFailed location err -> textual (show location ++ show err)++mkTok :: (t -> (Float, TeX, Float)) -> Loc t -> Tok+mkTok custPrintTok (Loc l t) = Tok (srcSpanStartColumn l) (srcSpanEndColumn l) before txt after+  where (before,txt,after) = custPrintTok t++haskellCust :: ParseMode -> (PrintTok) -> Verbatim a -> Tex ()+haskellCust mode custPrintTok v = case lexTokenStreamWithMode mode (fromVerbatim v) of+  ParseOk toks -> lineup (map (map (mkTok custPrintTok)) lins)+    where lins = groupBy ((==) `on` (srcSpanStartLine . loc)) toks+  ParseFailed location err -> textual (show location ++ show err)++splitTok :: String -> (String, Maybe String)+splitTok input = (reverse prefix ++ primes, if null numbers then Nothing else Just (reverse numbers))+  where (numbers,prefix) = span isDigit revNonPrimes+        (primes,revNonPrimes) = span (== '\'') revIn+        revIn = reverse input++printTok :: PrintTok+printTok t = let s = textual $ showToken t+                 ident = regular $ case splitTok $ showToken t of+                              (_,Nothing) -> cmd "mathsf" s+                              (pref,Just suff) -> cmd "mathsf" (textual pref) <> tex "_" <> braces (textual suff)+                 unquote = regular $ cmd "mathsf" s+                 quote = regular $ cmd "mathtt" s+                 literal = regular $ cmd "mathrm" s+                 string = regular $ cmd "texttt" s+                 keyword = regular $ cmd "mathbf" s+                 pragma = regular $ cmd "mathrm" s+                 symbol = regular $ cmd "mathnormal" s+                 regular tx = (5,tx,5)+                 leftParen  = (5,cmd "mathnormal" s,0)+                 rightParen = (0,cmd "mathnormal" s,5)+                 special x = regular $ cmd "mathnormal" $ tex x+                 debug = regular $ textual "[" <> ( cmd "mathnormal" $ textual $ show t) <> textual "]"+  in case t of+        -- _ -> cmd "mathrm" $ textual $ show t -- Debug+        VarId _ -> ident+        QVarId _ -> ident+        IDupVarId _ -> ident+        ILinVarId _ -> ident+        ConId _ -> ident+        QConId _ -> ident+        DVarId _ -> ident+        VarSym "==" -> special "\\equiv" -- ≡+        VarSym "=~" -> special "\\cong" -- ≅+        VarSym "<=" -> special "\\leq" -- ≤+        VarSym ">=" -> special "\\geq" -- ≥+        VarSym "<>" -> special "<\\!>"+        VarSym "<|>" -> special "<\\!\\mid\\!>"+        VarSym "<+>" -> special "<{\\mkern-12mu}+{\\mkern-12mu}>"+        VarSym "<*>" -> special "<{\\mkern-12mu}*{\\mkern-12mu}>"+        VarSym "<$>" -> special "<{\\mkern-12mu}\\${\\mkern-12mu}>"+        VarSym "++" -> special "+\\!+"+        VarSym _ -> symbol+        ConSym _ -> ident+        QVarSym _ -> ident+        QConSym _ -> ident+        IntTok _ -> literal+        FloatTok _ -> literal+        Character _ -> string+        StringTok _ -> string+        IntTokHash _ -> literal+        WordTokHash _ -> literal+        FloatTokHash _ -> literal+        DoubleTokHash _ -> literal+        CharacterHash _ -> literal+        StringHash _ -> literal+        LeftParen    -> leftParen+        RightParen -> rightParen+        LeftHashParen  -> symbol+        RightHashParen -> symbol+        SemiColon    -> symbol+        LeftCurly    -> leftParen+        RightCurly   -> rightParen+        VRightCurly -> rightParen+        LeftSquare   -> leftParen+        RightSquare          -> rightParen+        ParArrayLeftSquare   -> leftParen+        ParArrayRightSquare -> rightParen+        Comma -> rightParen+        Underscore -> symbol+        BackQuote -> symbol+        Dot -> symbol+        DotDot -> symbol+        Colon -> symbol+        QuoteColon -> symbol+        DoubleColon -> symbol+        Equals -> symbol+        Backslash -> symbol+        Bar -> symbol+        LeftArrow -> regular $ cmd0 "leftarrow"+        RightArrow -> regular $ cmd0 "rightarrow"+        At -> symbol+        Tilde -> symbol+        DoubleArrow -> regular $ cmd0 "Rightarrow"+        Minus -> symbol+        Exclamation -> symbol+        Star -> symbol+        LeftArrowTail -> symbol+        RightArrowTail -> symbol+        LeftDblArrowTail -> symbol+        RightDblArrowTail -> symbol+        THExpQuote -> symbol+        THPatQuote -> symbol+        THDecQuote -> symbol+        THTypQuote -> symbol+        THCloseQuote -> symbol+        THIdEscape _ -> unquote+        THParenEscape -> symbol+        THVarQuote -> symbol+        THTyQuote -> symbol+        THQuasiQuote _ -> quote+        RPGuardOpen -> symbol+        RPGuardClose -> symbol+        RPCAt -> symbol+        XCodeTagOpen -> symbol+        XCodeTagClose -> symbol+        XStdTagOpen -> symbol+        XStdTagClose -> symbol+        XCloseTagOpen -> symbol+        XEmptyTagClose -> symbol+        XChildTagOpen -> symbol+        XPCDATA _ -> symbol+        XRPatOpen -> symbol+        XRPatClose -> symbol+        PragmaEnd -> symbol+        RULES -> pragma+        INLINE _ -> pragma+        INLINE_CONLIKE -> pragma+        SPECIALISE -> pragma+        SPECIALISE_INLINE _ -> pragma+        SOURCE -> pragma+        DEPRECATED -> pragma+        WARNING -> pragma+        SCC -> pragma+        GENERATED -> pragma+        CORE -> pragma+        UNPACK -> pragma+        OPTIONS _ -> pragma+        LANGUAGE -> pragma+        ANN -> pragma+        MINIMAL -> pragma+        NO_OVERLAP -> pragma+        OVERLAP -> pragma+        INCOHERENT -> pragma+        KW_As -> keyword+        KW_By -> keyword+        KW_Case -> keyword+        KW_Class -> keyword+        KW_Data -> keyword+        KW_Default -> keyword+        KW_Deriving -> keyword+        KW_Do -> keyword+        KW_MDo -> keyword+        KW_Else -> keyword+        KW_Family -> keyword+        KW_Forall -> keyword+        KW_Group -> keyword+        KW_Hiding -> keyword+        KW_If -> keyword+        KW_Import -> keyword+        KW_In -> keyword+        KW_Infix -> keyword+        KW_InfixL -> keyword+        KW_InfixR -> keyword+        KW_Instance -> keyword+        KW_Let -> keyword+        KW_Module -> keyword+        KW_NewType -> keyword+        KW_Of -> keyword+        KW_Proc -> keyword+        KW_Rec -> keyword+        KW_Then -> keyword+        KW_Type -> keyword+        KW_Using -> keyword+        KW_Where -> keyword+        KW_Qualified -> keyword+        KW_Foreign -> keyword+        KW_Export -> keyword+        KW_Safe -> keyword+        KW_Unsafe -> keyword+        KW_Threadsafe -> keyword+        KW_Interruptible -> keyword+        KW_StdCall -> keyword+        KW_CCall -> keyword+        KW_CPlusPlus -> keyword+        KW_DotNet -> keyword+        KW_Jvm -> keyword+        KW_Js -> keyword+        KW_CApi -> keyword+        _ -> debug
MarXup/Math.hs view
@@ -54,6 +54,7 @@ -------------- -- Operators +infixr 1 =: (=:) = binop 0 "="  instance Num Math where@@ -76,6 +77,7 @@     log = fct (cmd "mathnormal" "log")     sin = fct (cmd "mathnormal" "sin")     cos = fct (cmd "mathnormal" "cos")+    tan = fct (cmd "mathnormal" "tan")     asin = fct (cmd "mathnormal" "asin")     acos = fct (cmd "mathnormal" "acos")     atan = fct (cmd "mathnormal" "atan")
MarXup/MultiRef.hs view
@@ -3,48 +3,47 @@ module MarXup.MultiRef where  import Control.Monad.Fix-import "mtl" Control.Monad.RWS.Lazy-import Control.Applicative-import Control.Arrow (first)+import Control.Monad.RWS.Lazy+import Data.Map.Strict (Map,insert)+import qualified Data.Map.Strict as M+import Graphics.Diagrams.Core (BoxSpec, nilBoxSpec)+type MetaData key = Map key String+type BoxSpecs = Map Int BoxSpec -newtype Multi a = Multi {fromMulti :: RWS InterpretMode String (References,[BoxSpec]) a }-  deriving (Functor, Monad, Applicative, MonadWriter String, MonadState (References,[BoxSpec]), MonadFix, MonadReader InterpretMode)+-- FIXME: Move boxspecs to the Read part.+newtype Multi config key a = Multi {fromMulti :: RWS config String (References,BoxSpecs,MetaData key) a }+  deriving (Functor, Monad, MonadReader config, Applicative, MonadWriter String, MonadState (References,BoxSpecs,MetaData key), MonadFix)  ----------------------------------- -- Basic datatype and semantics type Label = Int --- | Size of a box, in points. boxDepth is how far the baseline is--- from the bottom. boxHeight is how far the baseline is from the top.--- (These are TeX meanings)-data BoxSpec = BoxSpec {boxWidth, boxHeight, boxDepth :: Double}-             deriving (Show) -nilBoxSpec :: BoxSpec-nilBoxSpec = BoxSpec 0 0 0 -raw :: String -> Multi ()+raw :: String -> Multi config key () raw s = tell s -getBoxSpec :: Multi BoxSpec-getBoxSpec = do-  (refs,bs) <- get-  case bs of-    [] -> error "display: ran out of boxes!"-    (b:bs') -> do-      put (refs,bs')-      return b- +getBoxSpec :: Int -> Multi config key BoxSpec+getBoxSpec bxId = do+  (_,bs,_) <- get+  return $ case M.lookup bxId bs of+    Nothing -> nilBoxSpec -- TODO: log this error somehow+    Just b -> b +-- | allocate a new label+newLabel :: Multi key config Label -- create a new label+newLabel = do (r,bx,m) <- get+              put (r+1,bx,m)+              return r --- Reference management-newLabel :: Multi Label -- create a new label-newLabel = do x <- fst <$> get;  modify (first (+1)); return x+-- | output some meta data+metaData :: Ord key => key -> String -> Multi config key ()+metaData k val = do+   (r,bx,m) <- get+   put (r,bx,insert k val m)+   return ()  type References = Int -- how many labels have been allocated emptyRefs :: References emptyRefs = 0--type Mode = InterpretMode -> Bool-data InterpretMode = OutsideBox | InsideBox | Regular deriving Eq
MarXup/PrettyPrint/Core.hs view
@@ -5,7 +5,8 @@ import MarXup (textual) import MarXup.Latex import MarXup.Tex-import MarXup.MultiRef +import MarXup.MultiRef+import Graphics.Diagrams.Core (BoxSpec (..)) import MarXup.Diagram.Tikz (showDistance) import Data.Foldable (forM_) import Control.Applicative
MarXup/Tex.hs view
@@ -3,26 +3,67 @@ module MarXup.Tex where  import MarXup-import "mtl" Control.Monad.Reader-import "mtl" Control.Monad.RWS-import Control.Applicative+import Control.Monad.Reader+import Control.Monad.RWS import GHC.Exts( IsString(..) )-import Data.List (intersperse)+import Data.List (intersperse,intercalate) import MarXup.MultiRef-import System.Process import System.Directory (doesFileExist)+import Data.Char (isSpace)+import Data.Map (assocs, Map)+import qualified Data.Map as Map+import Graphics.Diagrams.Core (BoxSpec (..)) -newtype Tex a = Tex {fromTex :: Multi a}+data ClassFile = Plain | LNCS | SIGPlan | IEEE | EPTCS | Beamer+  deriving Eq+++------------------------------------+-- MetaData++data Key = PreClass String | PrePackage Int String | PreTheorem String String   -- priority+  deriving (Ord,Eq)++newtheorem :: String -> String -> TeX+newtheorem ident txt = do+  sty <- askClass+  unless ((sty == LNCS || sty == Beamer) && ident `elem` ["theorem", "corollary", "lemma", "definition", "proposition"]) $ do+  Tex $ metaData (PreTheorem ident txt) ""++usepkg :: String -> Int -> [String] -> TeX+usepkg ident prio options = Tex $ metaData (PrePackage prio ident) (intercalate "," options)++documentClass :: String -> [String] -> TeX+documentClass docClass options = Tex $ metaData (PreClass docClass) (intercalate "," options)+++renderKey :: Key -> String -> String+renderKey o options = case o of+  PreClass name -> "\\documentclass[" ++ options ++ "]{" ++ name ++ "}"+  PrePackage _ name -> "\\usepackage[" ++ options ++ "]{" ++ name ++ "}"+  PreTheorem ident txt  -> "\\newtheorem{" ++ ident ++ "}{" ++ txt ++ "}"++newtype Tex a = Tex {fromTex :: Multi ClassFile Key a}   deriving (Monad, MonadFix, Applicative, Functor) +++ --------------------------------- -- MarXup interface instance Textual Tex where-    textual s = tex $ concatMap escape s+  textual s = case break (== '\n') s of+    -- The 1st blank line of a MarXup chunk is replaced by a+    -- space. This means that to create a paragraph after an element,+    -- one needs a double blank line.+    (l,'\n':s') | all isSpace l -> tex (' ' : process s')+    _ -> tex $ process s+   where process = concatMap escape  kern :: String -> TeX kern x = braces $ tex $ "\\kern " ++ x +escape :: Char -> [Char] escape '\\' = "\\ensuremath{\\backslash{}}" escape '~' = "\\ensuremath{\\sim{}}" escape '<' = "\\ensuremath{<}"@@ -34,11 +75,8 @@   type Target (Tex a) = Tex a   element = id -texInMode ::  Mode -> String ->TeX-texInMode mode s = whenMode mode $ Tex $ raw s--tex :: String -> TeX-tex = texInMode (`elem` [Regular,InsideBox])+tex ::  String ->TeX+tex = Tex . raw  texComment :: String -> TeX texComment s =@@ -51,7 +89,7 @@ reference l = tex (show l)  instance Monoid (TeX) where-  mempty = textual ""+  mempty = tex ""   mappend = (>>)  instance IsString (TeX) where@@ -99,7 +137,7 @@   when (null args) $ tex "{}" -- so that this does not get glued with the next thing.   return res --- | Command with tex options and many arguments+-- | Command with tex options and several arguments cmdm :: String -> [Tex a] -> [Tex a] -> Tex [a] cmdm cmd options args = do   backslash >> tex cmd@@ -109,6 +147,7 @@   return res  +-- | Command with string options and several arguments; no result cmdn'_ :: String -> [String] -> [TeX] -> Tex () cmdn'_ cmd options args = cmdn' cmd options args >> return () @@ -116,8 +155,9 @@ cmdn :: String -> [Tex a] -> Tex [a] cmdn c args = cmdn' c [] args +-- | Command with n arguments, no result cmdn_ :: String -> [TeX] -> Tex ()-cmdn_ cmd args = cmdn'_ cmd [] args+cmdn_ theCmd args = cmdn'_ theCmd [] args  -- | Environment env :: String -> Tex a -> Tex a@@ -125,13 +165,13 @@  -- | Environment with options env' :: String -> [String] -> Tex a -> Tex a-env' e opts body = env'' e opts [] body+env' e opts body = env'' e (map textual opts) [] body --- | Environment with a tex option-env'' :: String -> [String] -> [TeX] -> Tex a -> Tex a+-- | Environment with tex options and tex arguments+env'' :: String -> [TeX] -> [TeX] -> Tex a -> Tex a env'' e opts args body = do   cmd "begin" $ tex e-  when (not $ null opts) $ brackets $ sequence_ $ map tex $ intersperse "," opts+  when (not $ null opts) $ brackets $ sequence_ $ intersperse (tex ",") opts   mapM_ braces args   x <- body   cmd "end" $ tex e@@ -171,88 +211,80 @@ ----------------- -- Generate boxes -outputAlsoInBoxMode :: Tex a -> Tex a-outputAlsoInBoxMode (Tex a) = Tex $ local moveInBox $ a-         where moveInBox m = case m of-                 OutsideBox -> InsideBox-                 _ -> m -texAlways = texInMode (const True)+inBox :: Tex a -> Tex (a, BoxSpec)+inBox = helpBox True -inBoxComputMode :: String -> TeX-inBoxComputMode = texInMode (`elem` [OutsideBox,InsideBox])+justBox :: Tex a -> Tex BoxSpec+justBox x = snd <$> helpBox False x -whenMode :: Mode -> Tex () -> Tex ()-whenMode mode act = do-  interpretMode <- Tex ask-  when (mode interpretMode) act -inBox :: Tex a -> Tex (a, BoxSpec)-inBox x = do-  inBoxComputMode $ "\n\\savebox{\\marxupbox}{"-  a <- outputAlsoInBoxMode x-  inBoxComputMode $ +helpBox :: Bool -> Tex a -> Tex (a,BoxSpec)+helpBox showBox x = do bxId <- Tex newLabel+                       a <- fillBox bxId showBox x+                       b <- Tex (getBoxSpec bxId)+                       return (a,b)++getBoxFromId :: Int -> Tex BoxSpec+getBoxFromId = Tex . getBoxSpec++fillBox :: Label -> Bool -> Tex a -> Tex a+fillBox bxId showBox x = braces $ do+  tex $ "\\savebox{\\marxupbox}{"+  a <- x+  tex $     "}"+    ++ "\\immediate\\write\\boxesfile{" ++ show bxId ++ "}"     ++ writeBox "wd"     ++ writeBox "ht"     ++ writeBox "dp"-    ++ "\n"-  b <- Tex getBoxSpec+  when showBox $ tex $ "\\box\\marxupbox" -  return (a,b)+  return a   where writeBox l = "\\immediate\\write\\boxesfile{\\number\\"++ l ++"\\marxupbox}" +-- TODO: it would be nice to have:+-- withBox :: Bool -> Tex a -> (Tex a -> Tex a) -> Tex BoxSpec+-- withBox showBox boxContents boxContext = ... -justBox :: Tex a -> Tex BoxSpec-justBox x = do-  whenMode (`elem` [OutsideBox, InsideBox]) $ outputAlsoInBoxMode $ do-    tex "\n\\savebox{\\marxupbox}{"-    x-    tex $ -      "}"-      ++ writeBox "wd"-      ++ writeBox "ht"-      ++ writeBox "dp"-      ++ "\n"-  b <- Tex getBoxSpec+-- however this may require some latex trickery. The idea would be to+-- create the box upfront (and thus we can obtain its boundaries), and+-- invoke it wherever the context calls it. This means that we need a+-- new 'box' for every invokation. It may be that latex does not have+-- infinitely many boxes, and thus we need to reuse (latex-side) box+-- ids. -  return b-  where writeBox l = "\\immediate\\write\\boxesfile{\\number\\"++ l ++"\\marxupbox}"+renderWithBoxes :: ClassFile -> BoxSpecs -> Tex a -> String+renderWithBoxes classFile bs (Tex t) = (preamble ++ doc)+  where (_,(_,_,metaDatum),doc) = runRWS (fromMulti $ t) classFile (0,bs,mempty)+        preamble :: String+        preamble = unlines $ map (uncurry renderKey) $ assocs metaDatum -renderWithBoxes :: [BoxSpec] -> InterpretMode -> Tex a -> String-renderWithBoxes bs mode (Tex t) = doc-  where (_,_,doc) = runRWS (fromMulti $ t) mode (0,bs)+renderSimple :: ClassFile -> Tex a -> String+renderSimple classFile = renderWithBoxes classFile Map.empty -renderSimple :: TeX -> String-renderSimple = renderWithBoxes [] Regular-  -renderTex :: (Bool -> TeX) -> TeX -> IO String-renderTex preamble body = do-  let bxsTex = renderWithBoxes (repeat nilBoxSpec) OutsideBox (wholeDoc True)-      boxesName = "mpboxes"-      boxesTxt = boxesName ++ ".txt"-      wholeDoc inBoxMode = do-        outputAlsoInBoxMode (preamble inBoxMode)-        inBoxComputMode $ "\\newwrite\\boxesfile"-        texAlways "\\begin{document}"-        inBoxComputMode $ "\\immediate\\openout\\boxesfile="++boxesTxt++"\n \\newsavebox{\\marxupbox}"-        body-        inBoxComputMode "\n\\immediate\\closeout\\boxesfile"-        texAlways "\\end{document}"-  writeFile (boxesName ++ ".tex") bxsTex-  system $ "latex " ++ boxesName-  boxes <- do+renderTex :: ClassFile -> String -> TeX -> IO ()+renderTex classFile fname body = do+  let boxesTxt = fname ++ ".boxes"+  boxes <- getBoxInfo . map read . lines <$> do     e <- doesFileExist boxesTxt     if e-      then do-        boxData <- map read . lines <$> readFile boxesTxt-        return $ getBoxInfo boxData-      else return []-  putStrLn $ "Number of boxes found: " ++ show (length boxes)-  return $ renderWithBoxes boxes Regular $ (wholeDoc False)+      then readFile boxesTxt+      else return ""+  putStrLn $ "Found " ++ show (length boxes) ++ " boxes"+  let texSource = renderWithBoxes classFile boxes wholeDoc+      wholeDoc = do+        tex $ "\\newwrite\\boxesfile"+        tex $ "\\immediate\\openout\\boxesfile="++boxesTxt++"\n\\newsavebox{\\marxupbox}"+        body+        tex "\n\\immediate\\closeout\\boxesfile"+  writeFile (fname ++ ".tex") texSource -getBoxInfo :: [Int] -> [BoxSpec]-getBoxInfo [] = []-getBoxInfo (width:height:depth:bs) = BoxSpec (scale width) (scale height) (scale depth):getBoxInfo bs+askClass :: Tex ClassFile+askClass = Tex ask++getBoxInfo :: [Int] -> Map Int BoxSpec+getBoxInfo (ident:width:height:depth:bs) = Map.insert ident (BoxSpec (scale width) (scale height) (scale depth)) (getBoxInfo bs)   where scale x = fromIntegral x / 65536+getBoxInfo _ = Map.empty
MarXup/Verbatim.hs view
@@ -4,12 +4,18 @@  import MarXup import Control.Monad.Fix+import Control.Monad (ap)+import Control.Applicative  data Verbatim a = Verbatim {fromVerbatim::String, value::a}   deriving Functor  instance Textual Verbatim where     textual s = Verbatim s ()++instance Applicative Verbatim where+    pure = return+    (<*>) = ap  instance Monad Verbatim where     return x = Verbatim "" x
+ MarXupParser.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE TupleSections, FlexibleInstances, TransformListComp #-}++module MarXupParser (parseFile, Haskell(..), MarXup(..)) where++import Text.ParserCombinators.Parsek.Position+import Data.Char+import Data.List+import System.IO+import Control.Monad+import GHC.Exts (the,groupWith)+import Config++-- todo: parse haskell comments (so that marxup there is not recognized)++------------------+-- Simple printing combinators, which do not add nor remove line breaks++data Haskell = HaskChunk String | HaskLn SourcePos | Quote [MarXup] | List [Haskell] | Parens [Haskell] | String String deriving (Show)+data MarXup = TextChunk String | Unquote (Maybe (SourcePos,String)) [(SourcePos,Haskell)] | Comment String deriving (Show)++----------------------------------------------+-- Parsing combinators++anyQuoteStrings :: [String]+anyQuoteStrings = concatMap (\(x,y) -> [x,y]) quoteStrings++pTextChunk = TextChunk <$> pChunk' (commentString : antiQuoteStrings ++ anyQuoteStrings) <?> "Text chunk"+pHaskChunk = HaskChunk <$> pChunk' (map box "\n\"[]()" ++ map fst quoteStrings) <?> "Haskell chunk"+    -- we keep track of balancing++pWPos :: Parser SourcePos+pWPos = do+  char '\n'+  getPosition++withPos :: Parser a -> Parser (SourcePos,a)+withPos p = do+  pos <- getPosition+  x <- p+  return (pos,x)++pHaskLn = HaskLn <$> pWPos -- before each newline, tell GHC where we are.++box = (:[])++pString :: Parser Haskell+pString = do+  char '"'+  result <- many (string "\\\"" <|> pChunk ['"'])+  char '"'+  return $ String $ concat result++-- | Parse some Haskell code with markup inside.+pHask :: Parser [Haskell]+pHask = many ((List <$> pArg "[]") <|>+              (Parens <$> pArg "()") <|>+              pTextArg  <|>+              pString <|>+              pHaskChunk <|>+              pHaskLn)++-- | Parse a text argument to an element+pTextArg' :: String -> String -> Parser Haskell+pTextArg' open close = Quote <$> (label "quoted text" $+  string open *>+  (many (pElement <|> pTextChunk <|> pComment))+  <* string close)++pTextArg :: Parser Haskell+pTextArg = choice $ map (uncurry pTextArg') quoteStrings++pArg :: String -> Parser [Haskell]+pArg [open,close] = char open *> pHask <*  char close++isIdentChar :: Char -> Bool+isIdentChar x = isAlphaNum x || (x `elem` "\'_")++pIdent :: Parser String+pIdent = munch1 isIdentChar <?> "identifier"++pArgument :: Parser Haskell+pArgument = (Parens <$> pArg "()" <|> (List <$> pArg "[]") <|> pTextArg <|> pString) <?> "argument"++pId :: Parser Haskell+pId = HaskChunk <$> pIdent++pElement :: Parser MarXup+pElement = +  label "Haskell element" $ do+    choice $ map string $ antiQuoteStrings+    var <- (Just <$> (withPos pIdent <* string "<-")) <<|> pure Nothing+    val <- ((:) <$> withPos pId <*> manyGreedy (withPos pArgument)) <|>+           (box <$> withPos (Parens <$> pArg "()"))+    return $ Unquote var val++commentString :: String+commentString = "%%"++pComment :: Parser MarXup+pComment = Comment <$> do+  label "Comment" $ do+    string commentString+    munch (/= '\n')+    string "\n"+    return mempty++parseFile :: String -> ([Haskell] -> IO ()) -> IO ()+parseFile fname k = do+  p <- parseFromFile (pHask <* endOfFile) completeResults fname+  case p of+    Left e -> handleErr e+    Right [res] -> k res+    Right _ -> hPutStrLn stderr "Amibiguous input!"++handleErr e =+   sequence_+          [ hPutStrLn stderr (show $ maybePosToPos $ the pos) >>+            hPutStrLn stderr ("  Expected:" ++ (intercalate " or " $ nub what))+           | (exps,_why) <- e, (what,pos) <- exps, then group by pos using groupWith, then reverse ]++----------------------------------------------+-- Parsing helpers++satisfy' :: (String -> Bool) -> Parser Char+satisfy' p = do+  l <- look+  unless (p l) $+    fail "Unexpected leading string"+  anySymbol++munch',munch1' :: (String -> Bool) -> Parser String+munch' p = scan =<< look+ where+  scan (c:cs) | p (c:cs) = (:) <$> anySymbol <*> scan cs+  scan _            = pure []++munch1' p = (:) <$> satisfy' p <*> munch' p++-- | A chunk not containing some strings+pChunk' :: [String] -> Parser String+pChunk' stops = munch1' (\l -> not $ any (`isPrefixOf` l) stops)+++-- | A chunk not containing some chars.+pChunk :: [Char] -> Parser String+pChunk stops = munch1 (not . (`elem` stops))+++-- Tests+testHask = parse "<interactive>" pHask completeResults "arst « text @z<-fct[x](y) awft"+testHask2 = parse "<interactive>" pHask completeResults "ars(t) « text @z<-fct[x](y) » awft"+testText2 = parse "<interactive>" pTextArg completeResults "« text @fct(x »"+testText3 = parse "<interactive>" pTextArg completeResults "« 1 @x 2 @y 3 @x 4 »"+testElem = parse "<interactive>" pElement completeResults "@x<-fct(x « yop »)[y]"+testChunk = parse "<interactive>" pHaskChunk completeResults "t"+testArg = parse "<interactive>" (pArg "()") completeResults "()"
+ Output.hs view
@@ -0,0 +1,43 @@+module Output where++import Text.ParserCombinators.Parsek.Position++import Data.Monoid+import Data.DList hiding (foldr, map)++------------------+-- Simple printing combinators, which do not add nor remove line breaks++type Doc = DList Char++text = fromList+x <+> y =  x <> text " " <> y+parens s = singleton '(' <> s <> singleton ')'+braces s = singleton '{' <> s <> singleton '}'+brackets s = singleton '[' <> s <> singleton ']'+doubleQuotes s = singleton '"' <> s <> singleton '"'++int x = text $ show x+hcat :: [Doc] -> Doc+hcat = foldr (<>) mempty+punctuate t = map (<> t)+render :: Doc -> String+render = toList++------------------------------------------+-- Output combinators++oPos :: SourcePos -> Doc+oPos EOF = mempty+oPos p = text "\n{-# LINE" <+> int (sourceLine p) <+> text (show (sourceName p)) <+> text "#-}\n" <>+         Data.DList.replicate (sourceCol p) ' '++oText :: String -> Doc+oText x = text "textual" <+> text (show x)++oConcat :: [Doc] -> Doc+oConcat [] = text "return ()"+oConcat [x] = x+oConcat l = text "do" <+> braces (text "rec" <+> braces (hcat (punctuate (text ";") binds)) <> text ";" <> ret)+  where binds = init l+        ret = last l
examples/LaTeX.hs view
@@ -1,28 +1,46 @@-{-# OPTIONS_GHC -XTypeSynonymInstances -XOverloadedStrings -XRecursiveDo -pgmF marxup3 -F #-}+{-# OPTIONS_GHC -XTypeSynonymInstances -XOverloadedStrings -XRecursiveDo -pgmF dist/build/marxup/marxup -F #-}  import MarXup import MarXup.Latex import MarXup.Latex.Math import MarXup.Math import MarXup.Tex+import MarXup.LineUp.Haskell import MarXup.DerivationTrees import MarXup.PrettyPrint as PP hiding (width) import MarXup.PrettyPrint.Core as PC import Control.Applicative import Data.Monoid import Control.Monad (unless)-import MarXup.Diagram-import MarXup.Diagram.Graphviz+import MarXup.Diagram as D+import Graphics.Diagrams.Plot+import Graphics.Diagrams.Graphviz import Control.Lens (set)-import Data.GraphViz+import Data.GraphViz hiding (Plain) import Data.String import Data.Traversable import Data.GraphViz.Attributes.Complete   (Attribute(RankSep,Shape,Label,Margin,Width,Len,RankDir),    Shape(..),Label(StrLabel),DPoint(..),RankDir(..))+import Numeric (showFFloat, showEFloat)  data SExp = Atom String | SX [SExp] +textualS = textual . ($ "")++aPlot :: Dia+aPlot = do+  c@(bx,_) <- simplePlot (Point (textualS . showFFloat (Just 1)) (textualS . showEFloat (Just 0)))+                         (vec (simplLinAxis 0.1,+                               logAxis 10+                               -- simplLinAxis 2000+                              ))+                         (map vec [(0.1,139),(0.35,10035),(0.23,1202)])+  functionPlot c 100 (\x -> 100 + 300000*(x-0.2)^^2)+  width bx === constant 200+  height bx === constant 100+  where vec (x,y) = Point x y+ prettyS :: SExp -> Tex Doc prettyS (Atom x) = PP.text (textual x) prettyS (SX xs) = do@@ -42,23 +60,16 @@   three = SX $ map Atom ["arstarsx","wftwfy","varstw","x","M"]   six = SX [ three , three , three ] -preamble inMP = do+preamble body = do   documentClass "article" []   usepackage "inputenc" ["utf8x"]-  unless inMP $ usepackage "tikz" []   usepackage "graphicx" []---- arrow :: Object -> Object -> Diagram Incidence--- arrow src trg = using (outline "black" . set endTip ToTip) $ do---   edge src trg--autoLab s i = do-  o <- labelObj s-  autoLabel o i+  env "document" body  (▸) = flip (#) -grDiag = graph Dot gr+grDiag :: TexDiagram ()+grDiag = graph tex Dot gr  nod x = DotNode x [Margin (DVal 0),Width 0, Shape Circle, Label $ StrLabel $ fromString x] edg x y z = DotEdge x y [Label $ StrLabel z, Len 0.1]@@ -71,21 +82,22 @@       ,edg "B" "D" "3"       ,edg "D" "A" "4"]) +testDiagram :: TexDiagram () testDiagram = do   -- draw $ path $ circle (Point 0 0) 5-  a   <- labelObj $ ensureMath $ "a"-  b   <- labelObj $ ensureMath $ "b"-  a'  <- draw $ circleShape -- labelObj $ ensureMath $ "c"-  width a' === 15-  b'  <- labelObj $ ensureMath $ "d"-  a'' <- labelObj $ ensureMath $ "."-  b'' <- labelObj $ ensureMath $ "."+  a   <- D.label "a" $ ensureMath $ "a"+  b   <- D.label "b" $ ensureMath $ "b"+  a'  <- draw $ circle "a'" -- label $ ensureMath $ "c"+  width a' === constant 15+  b'  <- D.label "b'" $ ensureMath $ "d"+  a'' <- D.label "a''" $ ensureMath $ "."+  b'' <- D.label "b''" $ ensureMath $ "."    -- c <- texObj $ ensureMath $ "c"   -- Center ▸ c === MP.center [E ▸ a'', E ▸ b''] + (20 +: 0) -  let width = 70-  vdist b a === 30+  let width = constant 70+  vdist b a === constant 30   hdist a a' === width   hdist a' a'' === width   alignMatrix [[Center ▸ a, Center ▸ a',Center ▸ a'']@@ -93,9 +105,9 @@               ]   autoLab "bing" =<< arrow a a'   autoLab "bang" =<< arrow b b'-  autoLab "oops" . swap =<< arrow a b+  autoLab "oops" . turn180 =<< arrow a b   autoLab "pif" =<< arrow a' a''-  autoLab "paf" =<< arrow b' b'' +  autoLab "paf" =<< arrow b' b''    draw $ do     autoLab "equal" =<< edge a'' b''@@ -129,8 +141,11 @@  (≜) = binop 1 "=" -main = writeFile ("LaTeX.tex") =<< renderTex preamble « +main = renderTex Plain "LaTeX" docu++docu = preamble «+ @intro<-section«Intro»  At-syntax is used to call a Haskell function. The result can be bound.@@ -168,20 +183,39 @@ @someTree  @section«Diagrams»--One can also draw diagrams: @testDiagram+One can also draw diagrams:  @section«Graphviz»  There is partial, rudimentary support for layout of graphs using graphviz. -grDiag+@grDiag+%% This is deactivated for now; it requires graphviz to be installed  +@section«Plots»++@aPlot++@cmd0"newpage"+@section«Haskell»++There is simple support for lhs2tex-style stuff.++Another paragaph.+++@haskell«++autoLab :: String -> OVector -> Diagram TeX Tex Object+autoLab s = autoLabel s (textual s)++»+some text after+ @concl<-section«Conclusion»  Mar@ensureMath«@cmd0"chi"»up is awesome :p .  »-
marxup.cabal view
@@ -1,76 +1,63 @@ name:           marxup-version:        3.0.0.1+version:        3.1.0.0 category:       Text synopsis:       Markup language preprocessor for Haskell description:   Markup syntax preprocessor for Haskell. Steals ideas from the Scribble project (in Scheme).   The package also provides a DSL to output Latex seamlessly from MarXup output.-license:        GPL+license:        GPL-2 license-file:   LICENSE author:         Jean-Philippe Bernardy maintainer:     jeanphilippe.bernardy@gmail.com Cabal-Version:  >= 1.8-tested-with:    GHC==6.12.1-tested-with:    GHC==7.4.1 build-type:     Simple  data-files:      examples/LaTeX.hs ---- executable marxup---   extensions: FlexibleInstances, TupleSections---   main-is: Main.hs---   build-depends: base>=4.2&&<=5---   build-depends: pretty==1.1.*---   build-depends: parsec>=3---   build-depends: dlist>=0.5+Flag example+  Description: Compile example. This will generally not work unless you know what you're doing.+  manual: True+  Default:     False -executable marxup3+executable marxup   extensions: FlexibleInstances, TupleSections-  main-is: Main3.hs+  main-is: Main.hs   build-depends: configurator>=0.2&&<2   build-depends: base>=4.2&&<=58   build-depends: pretty==1.1.*   build-depends: parsek==1.*   build-depends: dlist>=0.7-  other-modules: Config-  +  other-modules: Config, MarXupParser, Literate, Output+ library   extensions: FlexibleInstances, TypeSynonymInstances, GADTs   build-depends: base>=4.2&&<5 --  build-depends: pandoc==1.5.*  (support broken)   build-depends: mtl>=2.1   build-depends: labeled-tree==1.*-  build-depends: filepath==1.3.*+  build-depends: filepath>=1.3 && <2   build-depends: containers>=0.4 &&<1   build-depends: process>=1.1-  build-depends: glpk-hs>=0.3.4-  build-depends: cubicbezier>=0.2   build-depends: lens>=3.10   build-depends: directory>=1.2-  build-depends: typography-geometry-  build-depends: polynomials-bernstein==1.*-  build-depends: vector-  build-depends: graphviz+  build-depends: haskell-src-exts+  build-depends: lp-diagrams   build-depends: text    exposed-modules: MarXup   exposed-modules: MarXup.Tex   exposed-modules: MarXup.Latex   exposed-modules: MarXup.Latex.Math+  exposed-modules: MarXup.LineUp+  exposed-modules: MarXup.LineUp.Haskell   exposed-modules: MarXup.Math   exposed-modules: MarXup.Latex.Bib   exposed-modules: MarXup.Beamer   exposed-modules: MarXup.DerivationTrees   exposed-modules: MarXup.Text   exposed-modules: MarXup.Diagram-  exposed-modules: MarXup.Diagram.Object-  exposed-modules: MarXup.Diagram.Path-  exposed-modules: MarXup.Diagram.Point-  exposed-modules: MarXup.Diagram.Layout   exposed-modules: MarXup.Diagram.Tikz-  exposed-modules: MarXup.Diagram.Graphviz   exposed-modules: MarXup.MultiRef   exposed-modules: MarXup.Verbatim   exposed-modules: MarXup.PrettyPrint.Core@@ -78,3 +65,16 @@    --  exposed-modules: MarXup.Pandoc (broken) +executable marxup-example+   if  flag(example)+     buildable: True+   else+     buildable: False+   hs-source-dirs: examples+   main-is: LaTeX.hs+   build-depends: marxup+   build-depends: lp-diagrams+   build-depends: base+   build-depends: lens+   build-depends: graphviz+