Skip to content

Commit

Permalink
cleanup: make buildDiagram (and several other functions) take a Build…
Browse files Browse the repository at this point in the history 
…Opts record
  • Loading branch information
Brent Yorgey committed Nov 27, 2013
1 parent c63160e commit 05c17f8
Show file tree
Hide file tree
Showing 4 changed files with 146 additions and 80 deletions.
4 changes: 3 additions & 1 deletion diagrams-builder.cabal
View file
Expand Up @@ -44,6 +44,7 @@ Source-repository head

library
exposed-modules: Diagrams.Builder
Diagrams.Builder.Opts
Diagrams.Builder.Modules
Diagrams.Builder.CmdLine
build-depends: base >=4.2 && < 4.7,
Expand All @@ -57,7 +58,8 @@ library
haskell-src-exts >= 1.13.1 && < 1.15,
cryptohash >= 0.8 && < 0.12,
bytestring >= 0.9.2 && < 0.11,
cmdargs >= 0.6 && < 0.11
cmdargs >= 0.6 && < 0.11,
lens >= 3.9 && < 3.11
hs-source-dirs: src
default-language: Haskell2010
other-extensions: StandaloneDeriving,
Expand Down
109 changes: 37 additions & 72 deletions src/Diagrams/Builder.hs
View file
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-----------------------------------------------------------------------------
Expand All @@ -19,7 +20,11 @@
module Diagrams.Builder
( -- * Building diagrams

buildDiagram, BuildResult(..)
-- ** Options
BuildOpts(..), backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess

-- ** Building
, buildDiagram, BuildResult(..)
, ppInterpError

-- ** Regeneration decision functions
Expand All @@ -37,6 +42,7 @@ module Diagrams.Builder

) where

import Control.Lens ((^.))
import Control.Monad (guard, mplus, mzero)
import Control.Monad.Error (catchError)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
Expand All @@ -63,6 +69,7 @@ import Language.Haskell.Interpreter hiding (ModuleName)

import Diagrams.Builder.CmdLine
import Diagrams.Builder.Modules
import Diagrams.Builder.Opts
import Diagrams.Prelude hiding ((<.>))
import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)
import System.Environment (getEnvironment)
Expand Down Expand Up @@ -114,23 +121,30 @@ getHsenvArgv = do
-- source file, using some backend to produce a result. The
-- expression can be of type @Diagram b v@ or @IO (Diagram b v)@.
interpretDiagram
:: forall b v.
:: forall b v x.
( Typeable b, Typeable v
, InnerSpace v, OrderedField (Scalar v), Backend b v
)
=> b -- ^ Backend token
-> v -- ^ Dummy vector to identify the vector space
-> Options b v -- ^ Rendering options
-> FilePath -- ^ Filename of the module containing the example
-> [String] -- ^ Additional imports needed
-> String -- ^ Expression of type @Diagram b v@ to be compiled
=> BuildOpts b v x
-> FilePath
-> IO (Either InterpreterError (Result b v))
interpretDiagram b _ opts m imps dexp = do
args <- liftIO getHsenvArgv
unsafeRunInterpreterWithArgs args $ do
setDiagramImports m imps
d <- interpret dexp (as :: Diagram b v) `catchError` const (interpret dexp (as :: IO (Diagram b v)) >>= liftIO)
return (renderDia b opts d)
interpretDiagram bopts m = do

-- use an hsenv sandbox, if one is enabled.
args <- liftIO getHsenvArgv
unsafeRunInterpreterWithArgs args $ do

setDiagramImports m (bopts ^. imports)
let dexp = bopts ^. diaExpr

-- Try interpreting the diagram expression at two types: Diagram
-- b v and IO (Diagram b v). Take whichever one typechecks,
-- running the IO action in the second case to produce a
-- diagram.
d <- interpret dexp (as :: Diagram b v) `catchError` const (interpret dexp (as :: IO (Diagram b v)) >>= liftIO)

-- Finally, call renderDia.
return $ renderDia (backendToken bopts) (bopts ^. backendOpts) d

-- | Pretty-print an @InterpreterError@.
ppInterpError :: InterpreterError -> String
Expand Down Expand Up @@ -164,66 +178,17 @@ buildDiagram
, InnerSpace v, OrderedField (Scalar v), Backend b v
, Show (Options b v)
)
=> b
-- ^ Backend token

-> v
-- ^ Dummy vector to fix the vector type

-> Options b v
-- ^ Backend-specific options to use

-> [String]
-- ^ Source code snippets. Each should be a syntactically valid
-- Haskell module. They will be combined intelligently, /i.e./
-- not just pasted together textually but combining pragmas,
-- imports, /etc./ separately.

-> String
-- ^ Diagram expression to interpret

-> [String]
-- ^ Extra @LANGUAGE@ pragmas to use (@NoMonomorphismRestriction@
-- is used by default.)

-> [String]
-- ^ Additional imports ("Diagrams.Prelude" is imported by
-- default).

-> (String -> IO (x, Maybe (Options b v -> Options b v)))
-- ^ A function to decide whether a particular diagram needs to
-- be regenerated. It will be passed the final assembled
-- source for the diagram (but with the module name set to
-- @Main@ instead of something auto-generated, so that hashing
-- the source will produce consistent results across runs). It
-- can return some information (such as a hash of the source)
-- via the @x@ result, which will be passed through to the
-- result of 'buildDiagram'. More importantly, it decides
-- whether the diagram should be built: a result of 'Just'
-- means the diagram /should/ be built; 'Nothing' means it
-- should not. In the case that it should be built, it returns
-- a function for updating the rendering options. This could
-- be used, /e.g./, to request a filename based on a hash of
-- the source.
--
-- Two standard decision functions are provided for
-- convenience: 'alwaysRegenerate' returns no extra information
-- and always decides to regenerate the diagram;
-- 'hashedRegenerate' creates a hash of the diagram source and
-- looks for a file with that name in a given directory.

-> IO (BuildResult b v x)
buildDiagram b v opts source dexp langs imps shouldRegen = do
let source' = map unLit source
case createModule
Nothing
("NoMonomorphismRestriction" : langs)
("Diagrams.Prelude" : imps)
source' of
=> BuildOpts b v x -> IO (BuildResult b v x)
buildDiagram bopts = do
let bopts' = bopts
& snippets %~ map unLit
& pragmas %~ ("NoMonomorphismRestriction" :)
& imports %~ ("Diagrams.Prelude" :)
case createModule Nothing bopts' of
Left err -> return (ParseErr err)
Right m@(Module _ _ _ _ _ srcImps _) -> do
liHashes <- getLocalImportHashes srcImps
regen <- shouldRegen (prettyPrint m ++ dexp ++ show opts ++ concat liHashes)
regen <- (bopts ^. decideRegen) (prettyPrint m ++ (bopts ^. diaExpr) ++ show (bopts ^. backendOpts) ++ concat liHashes)
case regen of
(info, Nothing) -> return $ Skipped info
(info, Just upd) -> do
Expand All @@ -233,7 +198,7 @@ buildDiagram b v opts source dexp langs imps shouldRegen = do
hPutStr h (prettyPrint m')
hClose h

compilation <- interpretDiagram b v (upd opts) tmp imps dexp
compilation <- interpretDiagram (bopts' & backendOpts %~ upd) tmp
removeFile tmp
return $ either InterpErr (OK info) compilation

Expand Down
15 changes: 8 additions & 7 deletions src/Diagrams/Builder/Modules.hs
View file
Expand Up @@ -11,6 +11,7 @@

module Diagrams.Builder.Modules where

import Control.Lens ((^.))
import Data.Function (on)
import Data.List (foldl', groupBy, isPrefixOf, nub,
sortBy)
Expand All @@ -19,6 +20,8 @@ import Data.Ord (comparing)
import Language.Haskell.Exts
import Language.Haskell.Exts.SrcLoc (noLoc)

import Diagrams.Builder.Opts

------------------------------------------------------------
-- Manipulating modules
------------------------------------------------------------
Expand All @@ -32,17 +35,15 @@ import Language.Haskell.Exts.SrcLoc (noLoc)
-- Returns the updated module, or an error message if parsing
-- failed.
createModule :: Maybe String -- ^ Module name to use
-> [String] -- ^ @LANGUAGE@ pragmas to add
-> [String] -- ^ Imports to add
-> [String] -- ^ Source code
-> BuildOpts b v x
-> Either String Module
createModule nm langs imps srcs = do
ms <- mapM doModuleParse srcs
createModule nm opts = do
ms <- mapM doModuleParse (opts ^. snippets)
return
. deleteExports
. maybe id replaceModuleName nm
. addPragmas langs
. addImports imps
. addPragmas (opts ^. pragmas)
. addImports (opts ^. imports)
. foldl' combineModules emptyModule
$ ms

Expand Down
98 changes: 98 additions & 0 deletions src/Diagrams/Builder/Opts.hs
View file
@@ -0,0 +1,98 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Builder.Opts
-- Copyright : (c) 2013 diagrams-lib team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- Options for dynamic creation of diagrams.
--
-----------------------------------------------------------------------------
module Diagrams.Builder.Opts
(
BuildOpts(..), backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess
)
where

import Control.Lens (Lens', generateSignatures, lensRules,
makeLensesWith, (&), (.~))

import Diagrams.Prelude (Diagram, Options)

data BuildOpts b v x
= BuildOpts
{ backendToken :: b
-- ^ Backend token
, vectorToken :: v
-- ^ Dummy vector argument to fix the vector space type
, _backendOpts :: Options b v
, _snippets :: [String]
, _pragmas :: [String]
, _imports :: [String]
, _decideRegen :: String -> IO (x, Maybe (Options b v -> Options b v))
, _diaExpr :: String
, _postProcess :: Diagram b v -> Diagram b v
}

makeLensesWith (lensRules & generateSignatures .~ False) ''BuildOpts

-- | Backend-specific options to use.
backendOpts :: Lens' (BuildOpts b v x) (Options b v)

-- | Source code snippets. Each should be a syntactically valid
-- Haskell module. They will be combined intelligently, /i.e./
-- not just pasted together textually but combining pragmas,
-- imports, /etc./ separately.
snippets :: Lens' (BuildOpts b v x) [String]

-- | Extra @LANGUAGE@ pragmas to use (@NoMonomorphismRestriction@
-- is automatically enabled.)
pragmas :: Lens' (BuildOpts b v x) [String]

-- | Additional module imports (note that "Diagrams.Prelude" is
-- automatically imported).
imports :: Lens' (BuildOpts b v x) [String]

-- | A function to decide whether a particular diagram needs to
-- be regenerated. It will be passed the final assembled
-- source for the diagram (but with the module name set to
-- @Main@ instead of something auto-generated, so that hashing
-- the source will produce consistent results across runs). It
-- can return some information (such as a hash of the source)
-- via the @x@ result, which will be passed through to the
-- result of 'buildDiagram'. More importantly, it decides
-- whether the diagram should be built: a result of 'Just'
-- means the diagram /should/ be built; 'Nothing' means it
-- should not. In the case that it should be built, it returns
-- a function for updating the rendering options. This could
-- be used, /e.g./, to request a filename based on a hash of
-- the source.
--
-- Two standard decision functions are provided for
-- convenience: 'alwaysRegenerate' returns no extra information
-- and always decides to regenerate the diagram;
-- 'hashedRegenerate' creates a hash of the diagram source and
-- looks for a file with that name in a given directory.
decideRegen :: Lens' (BuildOpts b v x) (String -> IO (x, Maybe (Options b v -> Options b v)))

-- | The diagram expression to interpret. All the given import sand
-- snippets will be in scope, with the given LANGUAGE pragmas
-- enabled. The expression may have either of the types @Diagram b
-- v@ or @IO (Diagram b v)@.
diaExpr :: Lens' (BuildOpts b v x) String

-- | A function to apply to the interpreted diagram prior to
-- rendering. For example, you might wish to apply @pad 1.1
-- . centerXY@. This is preferred over directly modifying the
-- string expression to be interpreted, since it gives better
-- typechecking, and works no matter whether the expression
-- represents a diagram or an IO action.
postProcess :: Lens' (BuildOpts b v x) (Diagram b v -> Diagram b v)

0 comments on commit 05c17f8

Please sign in to comment.