noise (empty) → 0.0.1
raw patch · 22 files changed
+1697/−0 lines, 22 filesdep +HTFdep +HUnitdep +QuickChecksetup-changed
Dependencies added: HTF, HUnit, QuickCheck, base, blaze-markup, blaze-svg, bytestring, containers, cryptohash, network, noise, parsec, string-qq
Files
- LICENSE +21/−0
- README.md +53/−0
- Setup.hs +2/−0
- noise.cabal +74/−0
- src-cli/Main.hs +51/−0
- src/Text/Noise/Compiler.hs +136/−0
- src/Text/Noise/Compiler/Builtin.hs +100/−0
- src/Text/Noise/Compiler/Document.hs +140/−0
- src/Text/Noise/Compiler/Document/Color.hs +52/−0
- src/Text/Noise/Compiler/Error.hs +71/−0
- src/Text/Noise/Compiler/Function.hs +118/−0
- src/Text/Noise/Error.hs +55/−0
- src/Text/Noise/Parser.hs +111/−0
- src/Text/Noise/Parser/AST.hs +90/−0
- src/Text/Noise/Parser/Character.hs +28/−0
- src/Text/Noise/Parser/Language.hs +20/−0
- src/Text/Noise/Parser/Token.hs +87/−0
- src/Text/Noise/Parser/Token/Internal.hs +213/−0
- src/Text/Noise/Renderer.hs +156/−0
- src/Text/Noise/Renderer/SVG/Attributes.hs +71/−0
- src/Text/Noise/SourceRange.hs +36/−0
- tests/Main.hs +12/−0
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2013 Tom Brow++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,53 @@+# Noise++Noise is a concise, friendly language for graphic design that translates directly to [SVG 1.1](http://www.w3.org/TR/SVG11/). You can learn more about the language at [its webpage](http://tombrow.com/noise).++This project is an implementation of Noise written in [Haskell](http://haskell.org). It includes an interpreter and a library of modules that you can use to write your own interpreter.++## Installation++First, install the [Haskell Platform](http://www.haskell.org/platform/). Then:++ git clone git@github.com:brow/noise.git+ cd noise+ cabal install++Let's make sure it worked:++ $ noise --help+ Usage: noise [file]+ -h --help Print this help text.++## Usage++`noise` reads Noise code from standard input and writes SVG to standard output:++ echo "shape.circle(10,10,10,fill:color.red)" | noise > circle.svg++It can also read from a file:++ echo "shape.rectangle(0,0,10,10,fill:color.blue)" > rectangle.noise+ noise rectangle.noise > rectangle.svg++Use `convert` from the [ImageMagick](http://www.imagemagick.org/) package to write other image formats:++ echo "shape.circle(10,10,10,fill:color.green)" | noise | convert -size 20x20 svg:- circle.png++## Development++I recommend using `cabal-dev` to maintain a sandboxed build environment. If you don't have it already:++ cabal install cabal-dev++Then, in the project root:++ cabal-dev install-deps --enable-tests+ cabal-dev configure --enable-tests++After performing the above setup once, you can build and test `noise` like so:++ cabal-dev build && cabal-dev test++For a more detailed and colorful test report, try this:++ cabal-dev build && ./dist/build/test/test
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ noise.cabal view
@@ -0,0 +1,74 @@+name: noise+version: 0.0.1+synopsis: A friendly language for graphic design+description: A friendly language for graphic design+license: MIT+license-file: LICENSE+author: Tom Brow+copyright: Tom Brow+maintainer: Tom Brow <tom@tombrow.com>+category: Text+build-type: Simple+cabal-version: >=1.8+homepage: http://github.com/brow/noise+bug-reports: http://github.com/brow/noise/issues++extra-source-files:+ README.md++source-repository head+ type: git+ location: git://github.com/brow/noise.git++library+ ghc-options: -Wall+ hs-source-dirs: src+ build-depends:+ base ==4.5.*,+ blaze-markup ==0.5.*,+ blaze-svg ==0.3.*,+ bytestring ==0.9.*,+ containers ==0.4.*,+ cryptohash ==0.8.*,+ network ==2.3.*,+ parsec ==3.1.*+ exposed-modules:+ Text.Noise.Compiler+ Text.Noise.Compiler.Document+ Text.Noise.Compiler.Document.Color+ Text.Noise.Error+ Text.Noise.Parser+ Text.Noise.Parser.AST+ Text.Noise.Parser.Character+ Text.Noise.Renderer+ Text.Noise.SourceRange+ other-modules:+ Text.Noise.Compiler.Builtin+ Text.Noise.Compiler.Error+ Text.Noise.Compiler.Function+ Text.Noise.Parser.Token.Internal+ Text.Noise.Parser.Language+ Text.Noise.Parser.Token+ Text.Noise.Renderer.SVG.Attributes++executable noise+ ghc-options: -Wall+ hs-source-dirs: src-cli+ main-is: Main.hs+ build-depends:+ base ==4.5.*,+ noise++test-suite test+ ghc-options: -Wall+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Main.hs+ build-depends:+ HTF ==0.10.*,+ HUnit ==1.2.*,+ QuickCheck ==2.5.*,+ base ==4.5.*,+ parsec ==3.1.*,+ string-qq ==0.0.*,+ noise
+ src-cli/Main.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TupleSections #-}++import Control.Applicative+import qualified System.Environment as Env+import qualified System.Console.GetOpt as Opt+import qualified System.IO as IO+import qualified Text.Noise.Error as Error+import qualified Text.Noise.Parser as Parser+import qualified Text.Noise.Compiler as Compiler+import qualified Text.Noise.Renderer as Renderer+import qualified Text.Noise.SourceRange as SourceRange++main :: IO ()+main = do+ (flags, files, errors) <- getOptions+ runWithOptions flags files errors++runWithOptions :: [Flag] -> [String] -> [String] -> IO ()+runWithOptions [] files [] = do+ (sourceName, source) <- case files of+ [file] -> (file,) <$> readFile file+ [] -> ("-",) <$> getContents+ _ -> ioError (userError "multiple input files")+ case Parser.parse sourceName source of+ Left err -> printErr err+ Right ast -> case Compiler.compile ast of+ Left err -> printErr err+ Right doc -> putStr (Renderer.render doc)+ where printErr err = IO.hPutStrLn IO.stderr (showError err)+runWithOptions _ _ _ = putStr helpText++showError :: (Error.Error a) => a -> String+showError err = sourceName ++ ":" ++ line ++ ":" ++ column ++ ": " ++ message+ where message = Error.message err+ range = SourceRange.rangeInSource err+ line = show (SourceRange.startLine range)+ column = show (SourceRange.startColumn range)+ sourceName = SourceRange.sourceName range++data Flag = Help++optionsSpec :: [Opt.OptDescr Flag]+optionsSpec =+ [ Opt.Option "h" ["help"] (Opt.NoArg Help) "Print this help text."+ ]++getOptions :: IO ([Flag], [String], [String])+getOptions = Opt.getOpt Opt.Permute optionsSpec <$> Env.getArgs++helpText :: String+helpText = Opt.usageInfo "Usage: noise [file]" optionsSpec
+ src/Text/Noise/Compiler.hs view
@@ -0,0 +1,136 @@+module Text.Noise.Compiler+( compile+, CompileError(..)+, FunctionError(..)+) where++import Data.Function+import Data.Either (partitionEithers)+import Control.Monad+import Control.Applicative+import qualified Data.Map as Map+import qualified Data.List as List+import qualified Text.Noise.Parser.AST as AST+import qualified Text.Noise.Compiler.Document as D+import qualified Text.Noise.Compiler.Function as F+import qualified Text.Noise.Compiler.Builtin as Builtin+import Text.Noise.Compiler.Error (CompileError(..), FunctionError(..))++type Compiled a = Either CompileError a++type Definitions = Map.Map AST.IdentifierPath (F.Function F.Value)++data CompileState a = CompileState Definitions [a]++throw :: CompileError -> Compiled a+throw = Left++compile :: AST.SourceFile -> Compiled D.Document+compile (AST.SourceFile statements _) = do+ CompileState _ elems <- compileStatements statements+ return $ D.Document elems++compileStatementsWithDefs :: (F.FromValue a) => Definitions -> [AST.Statement] -> Compiled (CompileState a)+compileStatementsWithDefs defs = foldM compileStatement (CompileState defs [])++compileStatements :: (F.FromValue a) => [AST.Statement] -> Compiled (CompileState a)+compileStatements = compileStatementsWithDefs Builtin.definitions++compileStatement :: (F.FromValue a) => CompileState a -> AST.Statement -> Compiled (CompileState a)+compileStatement (CompileState defs xs) (AST.ExpressionStatement expression) = do+ value <- evaluate defs expression+ case F.fromValue value of+ Just x -> return $ CompileState defs (xs ++ [x])+ Nothing -> throw $ ExpressionStatementTypeError expression+compileStatement (CompileState defs elems) (AST.DefinitionStatement _ fnPrototype expression _) = do+ (functionPath, argNames) <- compileFunctionPrototype fnPrototype+ let definition = compileFunctionDef defs argNames expression+ return $ CompileState (Map.insert functionPath definition defs) elems++compileFunctionDef :: Definitions -> [AST.Identifier] -> AST.Expression -> F.Function F.Value+compileFunctionDef defs argNames expression = do+ argValues <- map return <$> mapM F.requireArg argNames+ let argDefs = Map.fromList $ zip (map return argNames) argValues+ let localDefs = argDefs `Map.union` defs+ case evaluate localDefs expression of+ Left err -> F.throw (F.CompileError err)+ Right value -> return value+ where++compileFunctionPrototype :: AST.FunctionPrototype -> Compiled (AST.IdentifierPath, [AST.Identifier])+compileFunctionPrototype (AST.FunctionPrototype (AST.QualifiedIdentifier path _) args _)+ | not $ null duplicateArgs = throw $ DuplicatedArgumentPrototypeError (head duplicateArgs)+ | otherwise = return (path, argNames)+ where duplicateArgs = duplicatesBy ((==) `on` argName) args+ argNames = [name | AST.RequiredArgumentPrototype name _ <- args]+ argName (AST.RequiredArgumentPrototype n _) = n++duplicatesBy :: (a -> a -> Bool) -> [a] -> [a]+duplicatesBy _ [] = []+duplicatesBy cmp (x:xs) =+ filter (cmp x) xs ++ duplicatesBy cmp (List.deleteBy cmp x xs)++evaluate :: Definitions -> AST.Expression -> Compiled F.Value+evaluate _ (AST.FloatLiteral x _) = return (F.NumberValue x)+evaluate _ (AST.ColorLiteral x _) = return (F.ColorValue x)+evaluate _ (AST.StringLiteral x _) = return (F.StringValue x)+evaluate defs (AST.FunctionCall identifier args block _) = do+ function <- lookUpFunction defs identifier+ (posArgs, kwArgs) <- evaluateArguments defs args+ blockArgs <- evaluateBlock defs block+ case F.call function posArgs kwArgs blockArgs of+ Left callError -> throw (FunctionCallError identifier callError)+ Right value -> return value+evaluate defs (AST.InfixOperation (AST.Operator op _) left right) =+ fmap F.NumberValue $ operationFn+ <$> evaluateOperand defs left+ <*> evaluateOperand defs right+ where operationFn = case op of+ AST.Add -> (+)+ AST.Sub -> (-)+ AST.Mul -> (*)+ AST.Div -> (/)+evaluate defs (AST.PrefixOperation (AST.Operator op _) expr) =+ fmap F.NumberValue $ operationFn <$> evaluateOperand defs expr+ where operationFn = case op of+ AST.Sub -> negate+ _ -> id++evaluateOperand :: Definitions -> AST.Expression -> Compiled D.Number+evaluateOperand defs expression = do+ value <- evaluate defs expression+ case F.fromValue value of+ Just x -> return x+ Nothing -> throw (OperandTypeError expression)++evaluateBlock :: Definitions -> Maybe AST.Block -> Compiled [F.Value]+evaluateBlock _ Nothing = return []+evaluateBlock defs (Just (AST.Block _ statements _ _)) = do+ CompileState _ elems <- compileStatementsWithDefs defs statements+ return elems++lookUpFunction :: Definitions -> AST.QualifiedIdentifier -> Compiled (F.Function F.Value)+lookUpFunction defs identifier@(AST.QualifiedIdentifier path _) =+ case Map.lookup path defs of+ Just fn -> return fn+ Nothing -> throw (UndefinedFunctionError identifier)++evaluateArguments :: Definitions -> [AST.Argument] -> Compiled ([F.Value], [(String, F.Value)])+evaluateArguments defs args+ | not $ null duplicateArgs = throw $ DuplicatedKeywordArgumentError (head duplicateArgs)+ | not $ null trailingPosArgs = throw $ PositionalArgumentError (head trailingPosArgs)+ | otherwise = partitionEithers <$> mapM (evaluateArgument defs) args+ where duplicateArgs = duplicatesBy ((==) `on` keyword) keywordArgs+ keywordArgs = filter (not . isPosArg) args+ keyword (AST.KeywordArgument k _ _) = k+ keyword _ = ""+ trailingPosArgs = dropWhile (not . isPosArg) $ dropWhile isPosArg args+ isPosArg (AST.PositionalArgument _) = True+ isPosArg _ = False++evaluateArgument :: Definitions -> AST.Argument -> Compiled (Either F.Value (String, F.Value))+evaluateArgument defs arg = case arg of+ AST.PositionalArgument expression ->+ Left <$> evaluate defs expression+ AST.KeywordArgument keyword expression _ ->+ Right . (,) keyword <$> evaluate defs expression
+ src/Text/Noise/Compiler/Builtin.hs view
@@ -0,0 +1,100 @@+module Text.Noise.Compiler.Builtin+( definitions+) where++import Control.Applicative+import qualified Data.Map as Map+import qualified Text.Noise.Compiler.Document as D+import qualified Text.Noise.Compiler.Function as F+import Text.Noise.Compiler.Function (Function, requireArg, acceptArg, acceptBlockArgs)++definitions :: Map.Map [String] (Function F.Value)+definitions = Map.fromList+ [ (["shape","rectangle"], rectangle)+ , (["shape","circle"], circle)+ , (["shape","path"], path)+ , (["color","red"], color "ff0000")+ , (["color","green"], color "00ff00")+ , (["color","blue"], color "0000ff")+ , (["color","black"], color "000000")+ , (["gradient","vertical"], linearGradient 90)+ , (["gradient","horizontal"], linearGradient 0)+ , (["gradient","radial"], radialGradient)+ , (["image"], image)+ , (["group"], group)+ , (["path","move"], pathMove)+ , (["path","line"], pathLine)+ , (["path","arc"], pathArc)+ ]++rectangle :: Function F.Value+rectangle = fmap F.ElementValue $ D.Rectangle+ <$> requireArg "x"+ <*> requireArg "y"+ <*> requireArg "width"+ <*> requireArg "height"+ <*> acceptArg "radius" 0+ <*> acceptArg "fill" D.defaultValue+ <*> acceptArg "stroke" D.defaultValue++circle :: Function F.Value+circle = fmap F.ElementValue $ D.Circle+ <$> requireArg "cx"+ <*> requireArg "cy"+ <*> requireArg "radius"+ <*> acceptArg "fill" D.defaultValue+ <*> acceptArg "stroke" D.defaultValue++color :: String -> Function F.Value+color = return . F.ColorValue++requireGradientColorArgs :: Function [(D.Number,D.Color)]+requireGradientColorArgs = do+ from <- requireArg "from"+ to <- requireArg "to"+ return [(0, from), (1, to)]++linearGradient :: D.Angle -> Function F.Value+linearGradient angle = fmap F.GradientValue $ D.LinearGradient angle+ <$> requireGradientColorArgs++radialGradient :: Function F.Value+radialGradient = fmap F.GradientValue $ D.RadialGradient+ <$> requireGradientColorArgs++image :: Function F.Value+image = fmap F.ElementValue $ D.Image+ <$> requireArg "x"+ <*> requireArg "y"+ <*> requireArg "width"+ <*> requireArg "height"+ <*> requireArg "file"++group :: Function F.Value+group = fmap F.ElementValue $ D.Group+ <$> acceptBlockArgs++path :: Function F.Value+path = fmap F.ElementValue $ D.Path+ <$> acceptArg "fill" D.defaultValue+ <*> acceptArg "stroke" D.defaultValue+ <*> acceptBlockArgs++pathMove :: Function F.Value+pathMove = fmap F.PathCommandValue $ D.Move+ <$> requireArg "dx"+ <*> requireArg "dy"++pathLine :: Function F.Value+pathLine = fmap F.PathCommandValue $ D.Line+ <$> requireArg "dx"+ <*> requireArg "dy"++pathArc :: Function F.Value+pathArc = fmap F.PathCommandValue $ do+ dx <- requireArg "dx"+ dy <- requireArg "dy"+ ry <- requireArg "ry"+ let rotation = atan(dy / dx)+ rx = sqrt(dx**2 + dy**2)+ return $ D.Arc dx dy rx ry rotation
+ src/Text/Noise/Compiler/Document.hs view
@@ -0,0 +1,140 @@+module Text.Noise.Compiler.Document+( Number+, Angle+, Coordinate+, Length+, Color+, IRI+, OpacityValue+, Paint(..)+, Gradient(..)+, Document(..)+, Element(..)+, PathCommand(..)+, circle+, rectangle+, path+, defaultValue+, showFuncIRI+, localIRIForId+, fileIRI+) where++import qualified Network.URI as URI+import Text.Noise.Compiler.Document.Color (Color)+import qualified Text.Noise.Compiler.Document.Color as Color++type Number = Double++type Angle = Number++type Length = Number++type Coordinate = Length++type IRI = URI.URI++type OpacityValue = Number++showFuncIRI :: IRI -> String+showFuncIRI iri = "url(" ++ show iri ++ ")"++isUnescapedInURIComponent :: Char -> Bool+isUnescapedInURIComponent c = not (URI.isReserved c || not (URI.isUnescapedInURI c))++localIRIForId :: String -> IRI+localIRIForId id' = URI.nullURI { URI.uriFragment = fragment }+ where fragment = '#' : URI.escapeURIString isUnescapedInURIComponent id'++fileIRI :: String -> Maybe IRI+fileIRI = URI.parseRelativeReference++data Gradient = LinearGradient { angle :: Angle+ , stops :: [(Number,Color)]+ }+ | RadialGradient { stops :: [(Number,Color)]+ }+ deriving (Eq, Show)++data Paint = ColorPaint Color+ | GradientPaint Gradient+ deriving (Show, Eq)++data Document = Document [Element] deriving (Show, Eq)++data Element = Rectangle { x :: Coordinate+ , y :: Coordinate+ , width :: Length+ , height :: Length+ , cornerRadius :: Length+ , fill :: Paint+ , stroke :: Paint+ }+ | Circle { cx :: Coordinate+ , cy :: Coordinate+ , r :: Length+ , fill :: Paint+ , stroke :: Paint+ }+ | Image { x :: Coordinate+ , y :: Coordinate+ , width :: Length+ , height :: Length+ , file :: IRI+ }+ | Group { members :: [Element]+ }+ | Path { fill :: Paint+ , stroke :: Paint+ , commands :: [PathCommand]+ }+ deriving (Show, Eq)++data PathCommand = Move { dx :: Coordinate+ , dy :: Coordinate+ }+ | Line { dx :: Coordinate+ , dy :: Coordinate+ }+ | Arc { dx :: Coordinate+ , dy :: Coordinate+ , rx :: Length+ , ry :: Length+ , xAxisRotation :: Angle+ }+ deriving (Show, Eq)++class Default a where+ defaultValue :: a++instance Default Color where+ defaultValue = Color.ARGB 0 0 0 0++instance Default Paint where+ defaultValue = ColorPaint defaultValue++instance Default Double where+ defaultValue = 0++circle :: Element+circle = Circle { cx = defaultValue+ , cy = defaultValue+ , r = defaultValue+ , fill = defaultValue+ , stroke = defaultValue+ }++path :: Element+path = Path { fill = defaultValue+ , stroke = defaultValue+ , commands = []+ }++rectangle :: Element+rectangle = Rectangle { x = defaultValue+ , y = defaultValue+ , width = defaultValue+ , height = defaultValue+ , cornerRadius = defaultValue+ , fill = defaultValue+ , stroke = defaultValue }
+ src/Text/Noise/Compiler/Document/Color.hs view
@@ -0,0 +1,52 @@+module Text.Noise.Compiler.Document.Color+( Color(..)+, toHex+, fromHex+, toRGBHex+, alpha+) where++import Data.Word+import Numeric (showHex, readHex)+import Control.Applicative++data Color = ARGB Word8 Word8 Word8 Word8+ | RGB Word8 Word8 Word8+ deriving (Eq, Show)++showHexByte :: Word8 -> String+showHexByte = pad . flip showHex ""+ where pad [x] = ['0', x]+ pad xs = xs++readHexByte :: String -> Maybe Word8+readHexByte str@[_,_] = case readHex str of+ [(i,"")] -> Just i+ _ -> Nothing+readHexByte _ = Nothing++toHex :: Color -> String+toHex color = concatMap showHexByte $ case color of+ ARGB a r g b -> [a ,r, g, b]+ RGB r g b -> [r, g, b]++toRGBHex :: Color -> String+toRGBHex color = toHex $ case color of+ ARGB _ r g b -> RGB r g b+ RGB {} -> color++fromHex :: String -> Maybe Color+fromHex [a0,a1,r0,r1,g0,g1,b0,b1] = ARGB+ <$> readHexByte [a0,a1]+ <*> readHexByte [r0,r1]+ <*> readHexByte [g0,g1]+ <*> readHexByte [b0,b1]+fromHex [r0,r1,g0,g1,b0,b1] = RGB+ <$> readHexByte [r0,r1]+ <*> readHexByte [g0,g1]+ <*> readHexByte [b0,b1]+fromHex _ = Nothing++alpha :: Color -> Maybe Double+alpha (ARGB a _ _ _) = Just (fromIntegral a / 255.0)+alpha _ = Nothing
+ src/Text/Noise/Compiler/Error.hs view
@@ -0,0 +1,71 @@+module Text.Noise.Compiler.Error+( FunctionError(..)+, CompileError(..)+) where++import qualified Data.List as List+import qualified Text.Noise.Parser.AST as AST+import qualified Text.Noise.Error as Error+import Text.Noise.SourceRange (HasSourceRange, rangeInSource)++data FunctionError = MissingArgumentError String+ | ArgumentTypeError String+ | BlockStatementTypeError+ | TooManyArgumentsError+ | CompileError CompileError+ | RedundantKeywordArgError String+ deriving (Show, Eq)++data CompileError = FunctionCallError AST.QualifiedIdentifier FunctionError+ | UndefinedFunctionError AST.QualifiedIdentifier+ | ExpressionStatementTypeError AST.Expression+ | PositionalArgumentError AST.Argument+ | DuplicatedArgumentPrototypeError AST.ArgumentPrototype+ | DuplicatedKeywordArgumentError AST.Argument+ | OperandTypeError AST.Expression+ deriving (Show, Eq)++instance HasSourceRange CompileError where+ rangeInSource err = case err of+ DuplicatedArgumentPrototypeError arg -> rangeInSource arg+ ExpressionStatementTypeError fnCall -> rangeInSource fnCall+ DuplicatedKeywordArgumentError arg -> rangeInSource arg+ UndefinedFunctionError identifier -> rangeInSource identifier+ PositionalArgumentError arg -> rangeInSource arg+ FunctionCallError _ (CompileError err') -> rangeInSource err'+ FunctionCallError fnCall _ -> rangeInSource fnCall+ OperandTypeError expression -> rangeInSource expression++instance Error.Error CompileError where+ message err =+ let showDotSyntax (AST.QualifiedIdentifier path _) = List.intercalate "." path+ showArgPrototypeName (AST.RequiredArgumentPrototype name _) = name+ showArgName (AST.KeywordArgument keyword _ _) = keyword+ showArgName _ = ""+ in case err of+ UndefinedFunctionError identifier ->+ "Undefined function \"" ++ showDotSyntax identifier ++ "\"."+ ExpressionStatementTypeError _ ->+ "Top-level expression is not an element."+ PositionalArgumentError _ ->+ "Positional argument follows a keyword argument."+ DuplicatedArgumentPrototypeError arg ->+ "Duplicate argument \"" ++ showArgPrototypeName arg ++ "\" in function definition."+ DuplicatedKeywordArgumentError arg ->+ "Duplicate keyword argument \"" ++ showArgName arg ++ "\" in function call."+ OperandTypeError _ ->+ "Operand is not a number."+ FunctionCallError identifier fnCallErr -> case fnCallErr of+ RedundantKeywordArgError keyword ->+ "Keyword argument \"" ++ keyword ++ "\" duplicates a positional argument."+ MissingArgumentError keyword ->+ "Function \"" ++ fnName ++ "\" requires argument \"" ++ keyword ++ "\"."+ ArgumentTypeError keyword ->+ "Argument \"" ++ keyword ++ "\" to function \"" ++ fnName ++ "\" has incorrect type."+ BlockStatementTypeError ->+ "Statement in block of function \"" ++ fnName ++ "\" has incorrect type."+ TooManyArgumentsError ->+ "Too many arguments to function \"" ++ fnName ++ "\"."+ CompileError err' ->+ Error.message err'+ where fnName = showDotSyntax identifier
+ src/Text/Noise/Compiler/Function.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TypeSynonymInstances #-}++module Text.Noise.Compiler.Function+( Function+, Value(..)+, FromValue(..)+, FunctionError(..)+, requireArg+, acceptArg+, acceptBlockArgs+, throw+, call+) where++import Control.Applicative+import Control.Monad+import Text.Noise.Compiler.Error (FunctionError(..))+import qualified Text.Noise.Compiler.Document as D+import qualified Text.Noise.Compiler.Document.Color as Color++type Keyword = String++data Value = NumberValue D.Number+ | ColorValue String+ | StringValue String+ | ElementValue D.Element+ | GradientValue D.Gradient+ | PathCommandValue D.PathCommand++data ArgStack = ArgStack [Value] [(Keyword,Value)] [Value]++data Result a = Success a ArgStack | Failure FunctionError++data Function a = Function { runFunction :: ArgStack -> Result a }++instance Functor Function where+ fmap = liftM++instance Applicative Function where+ pure = return+ (<*>) = ap++instance Monad Function where+ return x = Function $ \args -> Success x args+ Function r >>= f = Function $ \args ->+ case r args of+ Failure err -> Failure err+ Success x args' ->+ let Function r' = f x+ in r' args'++call :: Function a -> [Value] -> [(Keyword,Value)] -> [Value] -> Either FunctionError a+call function posArgs kwArgs blockArgs = case result of+ Failure err -> Left err+ Success _ (ArgStack (_:_) _ _) -> Left TooManyArgumentsError+ Success ret _ -> Right ret+ where result = runFunction function (ArgStack posArgs kwArgs blockArgs)++class FromValue a where+ fromValue :: Value -> Maybe a++instance FromValue Value where+ fromValue = Just++instance FromValue D.Number where+ fromValue (NumberValue x) = Just x+ fromValue _ = Nothing++instance FromValue D.Paint where+ fromValue (ColorValue x) = D.ColorPaint <$> Color.fromHex x+ fromValue (GradientValue x) = Just (D.GradientPaint x)+ fromValue _ = Nothing++instance FromValue D.Color where+ fromValue (ColorValue x) = Color.fromHex x+ fromValue _ = Nothing++instance FromValue D.IRI where+ fromValue (StringValue x) = D.fileIRI x+ fromValue _ = Nothing++instance FromValue D.Element where+ fromValue (ElementValue x) = Just x+ fromValue _ = Nothing++instance FromValue D.PathCommand where+ fromValue (PathCommandValue x) = Just x+ fromValue _ = Nothing++getArg :: (FromValue a) => Keyword -> Maybe a -> Function a+getArg keyword maybeDefault = Function $ \args -> case args of+ ArgStack (value:xs) kwArgs blockArgs -> case fromValue value of+ Just x -> case lookup keyword kwArgs of+ Nothing -> Success x (ArgStack xs kwArgs blockArgs)+ Just _ -> Failure (RedundantKeywordArgError keyword)+ Nothing -> Failure (ArgumentTypeError keyword)+ ArgStack [] kwArgs blockArgs -> case lookup keyword kwArgs of+ Just value -> case fromValue value of+ Just x -> Success x (ArgStack [] kwArgs blockArgs)+ Nothing -> Failure (ArgumentTypeError keyword)+ Nothing -> case maybeDefault of+ Just default' -> Success default' (ArgStack [] kwArgs blockArgs)+ Nothing -> Failure (MissingArgumentError keyword)++requireArg :: (FromValue a) => Keyword -> Function a+requireArg keyword = getArg keyword Nothing++acceptArg :: (FromValue a) => Keyword -> a -> Function a+acceptArg keyword default' = getArg keyword (Just default')++acceptBlockArgs :: (FromValue a) => Function [a]+acceptBlockArgs = Function $ \args@(ArgStack _ _ xs) ->+ case mapM fromValue xs of+ Just xs' -> Success xs' args+ Nothing -> Failure BlockStatementTypeError++throw :: FunctionError -> Function a+throw err = Function $ \_ -> Failure err
+ src/Text/Noise/Error.hs view
@@ -0,0 +1,55 @@+module Text.Noise.Error+( Error(..)+) where++import qualified Data.List as List+import qualified Text.Noise.SourceRange as SourceRange+import qualified Text.Parsec.Error as Parsec++class (SourceRange.HasSourceRange a) => Error a where+ message :: a -> String++instance Error Parsec.ParseError where+ message = showErrorMessages . Parsec.errorMessages++showErrorMessages :: [Parsec.Message] -> String+showErrorMessages msgs+ | null msgs = msgUnknown+ | otherwise = unwords $ map (++ ".") $ clean+ [showSysUnExpect,showUnExpect,showExpect,showMessages]+ where+ (sysUnExpect, msgs1) = span (Parsec.SysUnExpect "" ==) msgs+ (unExpect, msgs2) = span (Parsec.UnExpect "" ==) msgs1+ (expect, messages) = span (Parsec.Expect "" ==) msgs2++ showExpect = showMany msgExpecting expect+ showUnExpect = showMany msgUnExpected unExpect+ showSysUnExpect | not (null unExpect) ||+ null sysUnExpect = ""+ | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput+ | otherwise = msgUnExpected ++ " " ++ firstMsg+ where+ firstMsg = Parsec.messageString (head sysUnExpect)++ showMessages = showMany "" messages+ showMany pre msgs' = case clean (map Parsec.messageString msgs') of+ [] -> ""+ ms | null pre -> commasOr ms+ | otherwise -> pre ++ " " ++ commasOr ms++ commasOr [] = ""+ commasOr [m] = m+ commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms+ commaSep = seperate ", " . clean++ seperate _ [] = ""+ seperate _ [m] = m+ seperate sep (m:ms) = m ++ sep ++ seperate sep ms++ clean = List.nub . filter (not . null)++ msgOr = "or"+ msgUnknown = "Parse error"+ msgExpecting = "Expecting"+ msgUnExpected = "Unexpected"+ msgEndOfInput = "end of input"
+ src/Text/Noise/Parser.hs view
@@ -0,0 +1,111 @@+module Text.Noise.Parser+( parse+, ParseError+) where++import Control.Applicative+import Text.ParserCombinators.Parsec (ParseError, sepBy1, eof, option)+import Text.Parsec.Prim (try, (<?>))+import Text.Parsec.Pos (initialPos)+import qualified Text.Parsec.Expr as Expr+import qualified Text.Parsec.Prim (runParser)+import Text.Noise.Parser.Token (Parser, ranged)+import qualified Text.Noise.Parser.Token as Token+import qualified Text.Noise.Parser.AST as AST++parse :: String -> String -> Either ParseError AST.SourceFile+parse = Text.Parsec.Prim.runParser sourceFile (initialPos "" )++qualifiedIdentifier :: Parser AST.QualifiedIdentifier+qualifiedIdentifier = ranged+ (AST.QualifiedIdentifier <$> sepBy1 Token.identifier Token.dot)++floatLiteral :: Parser AST.Expression+floatLiteral = ranged (AST.FloatLiteral <$> Token.number)++colorLiteral :: Parser AST.Expression+colorLiteral = ranged (AST.ColorLiteral <$> Token.colorLiteral)++stringLiteral :: Parser AST.Expression+stringLiteral = ranged (AST.StringLiteral <$> Token.stringLiteral)++functionCall :: Parser AST.Expression+functionCall = ranged $ AST.FunctionCall+ <$> qualifiedIdentifier+ <*> option [] (Token.parens (Token.commaSeparated argument))+ <*> option Nothing (Just <$> block)++block :: Parser AST.Block+block = ranged $ AST.Block+ <$> reserved "with"+ <*> many statement+ <*> reserved "end"++operator :: AST.OperatorFunction -> Parser AST.Operator+operator op = ranged $ do+ Token.reservedOp str+ return (AST.Operator op)+ where str = case op of+ AST.Add -> "+"+ AST.Sub -> "-"+ AST.Mul -> "*"+ AST.Div -> "/"++expression :: Parser AST.Expression+expression = Expr.buildExpressionParser opTable term+ where opTable = [ [prefix AST.Sub]+ , [infixLeft AST.Mul, infixLeft AST.Div]+ , [infixLeft AST.Add, infixLeft AST.Sub] ]+ infixLeft op = Expr.Infix (AST.InfixOperation <$> operator op) Expr.AssocLeft+ prefix op = Expr.Prefix (AST.PrefixOperation <$> operator op)+ term = colorLiteral+ <|> floatLiteral+ <|> stringLiteral+ <|> functionCall+ <|> Token.parens expression+ <?> "expression"++expressionStatement :: Parser AST.Statement+expressionStatement = AST.ExpressionStatement <$> expression++argumentPrototype :: Parser AST.ArgumentPrototype+argumentPrototype = ranged (AST.RequiredArgumentPrototype <$> Token.identifier)++functionPrototype :: Parser AST.FunctionPrototype+functionPrototype = ranged $ AST.FunctionPrototype+ <$> qualifiedIdentifier+ <*> option [] (Token.parens (Token.commaSeparated argumentPrototype))++reserved :: String -> Parser AST.Reserved+reserved str = ranged $ Token.reserved str >> return (AST.Reserved str)++functionDefStatement :: Parser AST.Statement+functionDefStatement = ranged $ AST.DefinitionStatement+ <$> reserved "let"+ <*> functionPrototype <* Token.symbol "="+ <*> expression++statement :: Parser AST.Statement+statement = functionDefStatement+ <|> expressionStatement+ <?> "statement"++keywordArgument :: Parser AST.Argument+keywordArgument = ranged $ AST.KeywordArgument+ <$> try (Token.identifier <* Token.symbol ":")+ <*> expression++positionalArgument :: Parser AST.Argument+positionalArgument = AST.PositionalArgument <$> expression++argument :: Parser AST.Argument+argument = keywordArgument+ <|> positionalArgument+ <?> "argument"++sourceFile :: Parser AST.SourceFile+sourceFile = do+ Token.whiteSpace+ ast <- ranged (AST.SourceFile <$> many statement)+ eof+ return ast
+ src/Text/Noise/Parser/AST.hs view
@@ -0,0 +1,90 @@+module Text.Noise.Parser.AST+( SourceFile(..)+, QualifiedIdentifier(..)+, Identifier+, IdentifierPath+, OperatorFunction(..)+, Operator(..)+, Argument(..)+, Expression(..)+, Statement(..)+, Reserved(..)+, FunctionPrototype(..)+, ArgumentPrototype(..)+, Block(..)+) where++import Text.Noise.SourceRange (SourceRange, HasSourceRange(..))++data SourceFile = SourceFile [Statement] SourceRange deriving (Show, Eq)++data QualifiedIdentifier = QualifiedIdentifier IdentifierPath SourceRange deriving (Show, Eq)++type Identifier = String++data OperatorFunction = Add | Sub | Mul | Div deriving (Show, Eq)++type IdentifierPath = [Identifier]++data Reserved = Reserved String SourceRange deriving (Show, Eq)++data Statement = ExpressionStatement Expression+ | DefinitionStatement Reserved FunctionPrototype Expression SourceRange+ deriving (Show, Eq)++data FunctionPrototype = FunctionPrototype QualifiedIdentifier [ArgumentPrototype] SourceRange deriving (Show, Eq)++data ArgumentPrototype = RequiredArgumentPrototype Identifier SourceRange deriving (Show, Eq)++data Operator = Operator OperatorFunction SourceRange deriving (Show, Eq)++data Expression = FloatLiteral Double SourceRange+ | ColorLiteral String SourceRange+ | StringLiteral String SourceRange+ | FunctionCall QualifiedIdentifier [Argument] (Maybe Block) SourceRange+ | InfixOperation Operator Expression Expression+ | PrefixOperation Operator Expression+ deriving (Show, Eq)++data Argument = KeywordArgument Identifier Expression SourceRange+ | PositionalArgument Expression+ deriving (Show, Eq)++data Block = Block Reserved [Statement] Reserved SourceRange deriving (Show, Eq)++instance HasSourceRange SourceFile where+ rangeInSource (SourceFile _ r) = r++instance HasSourceRange QualifiedIdentifier where+ rangeInSource (QualifiedIdentifier _ r) = r++instance HasSourceRange Operator where+ rangeInSource (Operator _ r) = r++instance HasSourceRange Expression where+ rangeInSource (FloatLiteral _ r) = r+ rangeInSource (ColorLiteral _ r) = r+ rangeInSource (StringLiteral _ r) = r+ rangeInSource (FunctionCall _ _ _ r) = r+ rangeInSource (InfixOperation _ e0 e1) = (fst (rangeInSource e0), snd (rangeInSource e1))+ rangeInSource (PrefixOperation op expr) = (fst (rangeInSource op), snd (rangeInSource expr))++instance HasSourceRange Argument where+ rangeInSource (KeywordArgument _ _ r) = r+ rangeInSource (PositionalArgument expr) = rangeInSource expr++instance HasSourceRange Statement where+ rangeInSource (ExpressionStatement expression) = rangeInSource expression+ rangeInSource (DefinitionStatement _ _ _ r) = r++instance HasSourceRange FunctionPrototype where+ rangeInSource (FunctionPrototype _ _ r) = r++instance HasSourceRange ArgumentPrototype where+ rangeInSource (RequiredArgumentPrototype _ r) = r++instance HasSourceRange Reserved where+ rangeInSource (Reserved _ r) = r++instance HasSourceRange Block where+ rangeInSource (Block _ _ _ r) = r
+ src/Text/Noise/Parser/Character.hs view
@@ -0,0 +1,28 @@+module Text.Noise.Parser.Character+( Location+, Length+, Range+, locationAt+, rangeAt+) where++import Text.Parsec.Pos (SourcePos, updatePosChar, initialPos, sourceName)+import Text.Noise.SourceRange (SourceRange)+import Data.List (elemIndex)++type Location = Int++type Length = Int++type Range = (Location, Length)++locationAt :: String -> SourcePos -> Maybe Location+locationAt source pos = elemIndex pos positions+ where positions = scanl updatePosChar firstPos source+ firstPos = initialPos (sourceName pos)++rangeAt :: String -> SourceRange -> Maybe Range+rangeAt source (fromPos, toPos) = do+ fromLoc <- locationAt source fromPos+ toLoc <- locationAt source toPos+ return (fromLoc, toLoc - fromLoc)
+ src/Text/Noise/Parser/Language.hs view
@@ -0,0 +1,20 @@+module Text.Noise.Parser.Language+( def+) where++import Text.Parsec+import Text.Parsec.Token as Parsec.Token++def :: Parsec.Token.LanguageDef st+def = Parsec.Token.LanguageDef+ { commentStart = "/*"+ , commentEnd = "*/"+ , commentLine = "//"+ , nestedComments = True+ , identStart = letter <|> char '_'+ , identLetter = alphaNum <|> char '_'+ , opStart = parserZero+ , opLetter = parserZero+ , reservedNames = ["let", "with", "end"]+ , reservedOpNames = ["+", "-", "*", "/"]+ , caseSensitive = True }
+ src/Text/Noise/Parser/Token.hs view
@@ -0,0 +1,87 @@+module Text.Noise.Parser.Token+( Parser+, ranged+, identifier+, number+, colorLiteral+, stringLiteral+, whiteSpace+, parens+, commaSeparated+, dot+, symbol+, reserved+, reservedOp+) where++import Control.Monad+import Control.Applicative+import Text.Parsec hiding (many, (<|>))+import qualified Text.Parsec.Token as Parsec.Token+import Text.Noise.SourceRange (SourceRange)+import qualified Text.Noise.Parser.Token.Internal as Internal+import qualified Text.Noise.Parser.Language as Language+import qualified Text.Noise.Parser.AST as AST++{-# ANN module "HLint: ignore Use string literal" #-}++type Parser = Parsec String SourcePos++markPosition :: Parser ()+markPosition = getPosition >>= setState++getMarkedPosition :: Parser SourcePos+getMarkedPosition = getState++ranged :: Parser (SourceRange -> a) -> Parser a+ranged p = do+ start <- getPosition+ x <- p+ end <- getMarkedPosition+ return $ x (start, end)++whiteSpace :: Parser ()+whiteSpace = Parsec.Token.whiteSpace tokenParser+ where tokenParser = Parsec.Token.makeTokenParser Language.def++lexeme :: Parser a -> Parser a+lexeme p = p <* markPosition <* whiteSpace++identifier :: Parser AST.Identifier+identifier = lexeme Internal.identifier++number :: Parser Double+number = lexeme $ do+ naturalOrFloat <- Internal.natFloat+ return $ case naturalOrFloat of+ Left integer -> fromInteger integer+ Right double -> double++colorLiteral :: Parser String+colorLiteral = lexeme (char '#' >> colorStr)+ where colorStr = try hexColorStr <?> "hex color of form RRGGBB or AARRGGBB"+ hexColorStr = do+ str <- many hexDigit+ unless (length str `elem` [6,8]) (unexpected "color format")+ return str++stringLiteral :: Parser String+stringLiteral = lexeme Internal.stringLiteral++parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++commaSeparated :: Parser a -> Parser [a]+commaSeparated p = sepEndBy p (symbol ",")++dot :: Parser String+dot = symbol "."++symbol :: String -> Parser String+symbol = lexeme . string++reserved :: String -> Parser ()+reserved = lexeme . Internal.reserved++reservedOp :: String -> Parser ()+reservedOp = lexeme . Internal.reservedOp
+ src/Text/Noise/Parser/Token/Internal.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind -fno-warn-name-shadowing #-}++module Text.Noise.Parser.Token.Internal+( identifier+, natFloat+, stringLiteral+, reserved+, reservedOp+) where++import Data.Char (isAlpha, toLower, toUpper, digitToInt)+import Data.List (sort)+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator+import Text.Parsec.Token+ ( caseSensitive+ , reservedNames+ , identStart+ , identLetter+ , opLetter+ )+import qualified Text.Noise.Parser.Language++{-# ANN module "HLint: ignore" #-}++languageDef = Text.Noise.Parser.Language.def++identifier =+ try $+ do{ name <- ident+ ; if (isReservedName name)+ then unexpected ("reserved word " ++ show name)+ else return name+ }++ident+ = do{ c <- identStart languageDef+ ; cs <- many (identLetter languageDef)+ ; return (c:cs)+ }+ <?> "identifier"++isReservedName name+ = isReserved theReservedNames caseName+ where+ caseName | caseSensitive languageDef = name+ | otherwise = map toLower name++isReserved names name+ = scan names+ where+ scan [] = False+ scan (r:rs) = case (compare r name) of+ LT -> scan rs+ EQ -> True+ GT -> False++theReservedNames+ | caseSensitive languageDef = sort reserved+ | otherwise = sort . map (map toLower) $ reserved+ where+ reserved = reservedNames languageDef++natFloat = do{ char '0'+ ; zeroNumFloat+ }+ <|> decimalFloat++zeroNumFloat = do{ n <- hexadecimal <|> octal+ ; return (Left n)+ }+ <|> decimalFloat+ <|> fractFloat 0+ <|> return (Left 0)++decimalFloat = do{ n <- decimal+ ; option (Left n)+ (fractFloat n)+ }++fractFloat n = do{ f <- fractExponent n+ ; return (Right f)+ }++fractExponent n = do{ fract <- fraction+ ; expo <- option 1.0 exponent'+ ; return ((fromInteger n + fract)*expo)+ }+ <|>+ do{ expo <- exponent'+ ; return ((fromInteger n)*expo)+ }++fraction = do{ char '.'+ ; digits <- many1 digit <?> "fraction"+ ; return (foldr op 0.0 digits)+ }+ <?> "fraction"+ where+ op d f = (f + fromIntegral (digitToInt d))/10.0++exponent' = do{ oneOf "eE"+ ; f <- sign+ ; e <- decimal <?> "exponent"+ ; return (power (f e))+ }+ <?> "exponent"+ where+ power e | e < 0 = 1.0/power(-e)+ | otherwise = fromInteger (10^e)++sign = (char '-' >> return negate)+ <|> (char '+' >> return id)+ <|> return id++decimal = number 10 digit+hexadecimal = do{ oneOf "xX"; number 16 hexDigit }+octal = do{ oneOf "oO"; number 8 octDigit }++number base baseDigit+ = do{ digits <- many1 baseDigit+ ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits+ ; seq n (return n)+ }++stringLiteral = do{ str <- between (char '"')+ (char '"' <?> "end of string")+ (many stringChar)+ ; return (foldr (maybe id (:)) "" str)+ }+ <?> "literal string"++stringChar = do{ c <- stringLetter; return (Just c) }+ <|> stringEscape+ <?> "string character"++stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))++stringEscape = do{ char '\\'+ ; do{ escapeGap ; return Nothing }+ <|> do{ escapeEmpty; return Nothing }+ <|> do{ esc <- escapeCode; return (Just esc) }+ }++escapeEmpty = char '&'++escapeGap = do{ many1 space+ ; char '\\' <?> "end of string gap"+ }++escapeCode = charEsc <|> charNum <|> charAscii <|> charControl+ <?> "escape code"++charControl = do{ char '^'+ ; code <- upper+ ; return (toEnum (fromEnum code - fromEnum 'A'))+ }++charNum = do{ code <- decimal+ <|> do{ char 'o'; number 8 octDigit }+ <|> do{ char 'x'; number 16 hexDigit }+ ; return (toEnum (fromInteger code))+ }++charEsc = choice (map parseEsc escMap)+ where+ parseEsc (c,code) = do{ char c; return code }++charAscii = choice (map parseAscii asciiMap)+ where+ parseAscii (asc,code) = try (do{ string asc; return code })+++escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"+asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)++ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",+ "FS","GS","RS","US","SP"]+ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",+ "CAN","SUB","ESC","DEL"]++ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',+ '\EM','\FS','\GS','\RS','\US','\SP']+ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',+ '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',+ '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']++reserved name =+ try $+ do{ caseString name+ ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)+ }++caseString name+ | caseSensitive languageDef = string name+ | otherwise = do{ walk name; return name }+ where+ walk [] = return ()+ walk (c:cs) = do{ caseChar c <?> msg; walk cs }++ caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c)+ | otherwise = char c++ msg = show name++reservedOp name =+ try $+ do{ string name+ ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)+ }
+ src/Text/Noise/Renderer.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++module Text.Noise.Renderer (render) where++import Prelude hiding ((!!))+import Data.List hiding ((!!))+import Data.Monoid+import Data.Function+import Data.Maybe+import Control.Monad+import Control.Applicative+import qualified Numeric+import qualified Data.List as List+import qualified Data.ByteString as ByteString+import qualified Crypto.Hash.SHA1 as SHA1+import qualified Text.Blaze.Internal as Blaze+import qualified Text.Blaze.Svg11 as SVG+import qualified Text.Blaze.Svg11.Attributes as SVG.At+import Text.Blaze.Svg11 ((!), Svg)+import qualified Text.Blaze.Svg.Renderer.Pretty as Pretty+import qualified Text.Blaze.Svg.Renderer.Utf8 as Utf8+import qualified Text.Noise.Renderer.SVG.Attributes as At+import qualified Text.Noise.Compiler.Document as D+import qualified Text.Noise.Compiler.Document.Color as Color++class Renderable a where+ renderToInlineSvg :: a -> InlineSvg+ renderToSvg :: a -> Svg+ render :: a -> String+ renderToInlineSvg = InlineSvg [] . renderToSvg+ renderToSvg = uninline . renderToInlineSvg+ render = Pretty.renderSvg . renderToSvg++instance (Renderable a) => Renderable [a] where+ renderToInlineSvg = mconcat . map renderToInlineSvg++data InlineSvg = InlineSvg [(String, Svg)] Svg++data InlineAttribute = InlineAttribute (Maybe (String, Svg)) SVG.Attribute++instance Monoid InlineSvg where+ mempty = InlineSvg [] mempty+ mappend (InlineSvg defs svg) (InlineSvg defs' svg') =+ InlineSvg (List.unionBy ((==) `on` fst) defs defs') (svg <> svg')++(?) :: InlineSvg -> InlineAttribute -> InlineSvg+(InlineSvg defs svg) ? (InlineAttribute attrDef attr) = InlineSvg defs' svg'+ where svg' = svg ! attr+ defs' = case attrDef of+ Just def -> def : defs+ Nothing -> defs++(!!) :: Svg -> [SVG.Attribute] -> Svg+svg !! attrs = foldl' (!) svg attrs++(??) :: InlineSvg -> [InlineAttribute] -> InlineSvg+inlineSvg ?? attrs = foldl' (?) inlineSvg attrs++inline :: Svg -> InlineSvg+inline = InlineSvg []++uninline :: InlineSvg -> Svg+uninline (InlineSvg defs main) = SVG.defs (mconcat $ map snd defs) <> main++instance Blaze.Attributable InlineSvg where+ (!) (InlineSvg defs main) attr = InlineSvg defs (main ! attr)++instance Renderable D.Document where+ renderToSvg (D.Document elems) =+ SVG.docTypeSvg $ uninline $ mconcat $ map renderToInlineSvg elems++instance Renderable D.Element where+ renderToInlineSvg (D.Rectangle x y w h radius fill stroke) = inline SVG.rect+ ! At.x x+ ! At.y y+ ! At.width w+ ! At.height h+ ! At.rx radius+ ?? fillAttrs fill+ ?? strokeAttrs stroke++ renderToInlineSvg (D.Circle cx cy r fill stroke) = inline SVG.circle+ ! At.cx cx+ ! At.cy cy+ ! At.r r+ ?? fillAttrs fill+ ?? strokeAttrs stroke++ renderToInlineSvg (D.Image x y w h file) = inline SVG.image+ ! At.x x+ ! At.y y+ ! At.width w+ ! At.height h+ ! At.xlinkHref file+ ! At.preserveaspectratio "none"++ renderToInlineSvg (D.Path fill stroke commands) = inline SVG.path+ ! At.d (concatMap renderPathCommand commands)+ ?? fillAttrs fill+ ?? strokeAttrs stroke++ renderToInlineSvg (D.Group members) = InlineSvg defs (SVG.g innerSvg)+ where InlineSvg defs innerSvg = renderToInlineSvg members++instance Renderable D.Gradient where+ renderToSvg gradient = svgGradient $ forM_ (D.stops gradient) $ \(offset, color) ->+ SVG.stop+ ! At.offset offset+ !! stopColorAttrs color+ where+ svgGradient = case gradient of+ (D.RadialGradient _ ) -> SVG.radialgradient+ (D.LinearGradient angle _ ) ->+ let radians = angle * pi / 180+ in SVG.lineargradient+ ! At.x2 (cos radians)+ ! At.y2 (sin radians)++colorValue :: D.Color -> SVG.AttributeValue+colorValue = Blaze.stringValue . ('#' :) . Color.toRGBHex++svgAttr :: (Renderable a) => (SVG.AttributeValue -> SVG.Attribute) -> a -> InlineAttribute+svgAttr attrFn x = InlineAttribute (Just (uniqueId, svg')) $ attrFn (Blaze.stringValue funcIRI)+ where svg = renderToSvg x+ svg' = svg ! At.id uniqueId+ funcIRI = D.showFuncIRI (D.localIRIForId uniqueId)+ uniqueId = List.foldl' (flip Numeric.showHex) "" $ ByteString.unpack sha+ sha = SHA1.hashlazy (Utf8.renderSvg svg)++paintAttrs :: (SVG.AttributeValue -> SVG.Attribute)+ -> (D.OpacityValue -> SVG.Attribute)+ -> D.Paint+ -> [InlineAttribute]+paintAttrs paintServerAttrFn opacityAttrFn paint = case paint of+ D.GradientPaint gradient -> [ svgAttr paintServerAttrFn gradient ]+ D.ColorPaint color -> map (InlineAttribute Nothing) (paintServerAttr : maybeToList opacityAttr)+ where opacityAttr = opacityAttrFn <$> Color.alpha color+ paintServerAttr = paintServerAttrFn (colorValue color)++fillAttrs :: D.Paint -> [InlineAttribute]+fillAttrs = paintAttrs SVG.At.fill At.fillOpacity++strokeAttrs :: D.Paint -> [InlineAttribute]+strokeAttrs = paintAttrs SVG.At.stroke At.strokeOpacity++stopColorAttrs :: D.Color -> [SVG.Attribute]+stopColorAttrs color = stopColorAttr : maybeToList stopOpacityAttr+ where stopOpacityAttr = At.stopOpacity <$> Color.alpha color+ stopColorAttr = SVG.At.stopColor (colorValue color)++renderPathCommand :: D.PathCommand -> String+renderPathCommand command = unwords $ case command of+ D.Move dx dy -> "m" : map show [dx, dy]+ D.Line dx dy -> "l" : map show [dx, dy]+ D.Arc x y rx ry rotation ->+ ["a", show rx, show ry, show rotation, "0", "0", show x, show y]
+ src/Text/Noise/Renderer/SVG/Attributes.hs view
@@ -0,0 +1,71 @@+module Text.Noise.Renderer.SVG.Attributes where++import Numeric+import Text.Blaze.Internal (Attribute, stringValue)+import qualified Text.Blaze.Svg11.Attributes as SVG+import qualified Text.Noise.Compiler.Document as D++x :: D.Coordinate -> Attribute+x = SVG.x . stringValue . show++y :: D.Coordinate -> Attribute+y = SVG.y . stringValue . show++width :: D.Length -> Attribute+width = SVG.width . stringValue . show++height :: D.Length -> Attribute+height = SVG.height . stringValue . show++cx :: D.Coordinate -> Attribute+cx = SVG.cx . stringValue . show++cy :: D.Coordinate -> Attribute+cy = SVG.cy . stringValue . show++r :: D.Length -> Attribute+r = SVG.r . stringValue . show++rx :: D.Coordinate -> Attribute+rx = SVG.rx . stringValue . show++offset :: D.Number -> Attribute+offset = SVG.offset . stringValue . show++id :: String -> Attribute+id = SVG.id_ . stringValue++x1 :: D.Number -> Attribute+x1 = SVG.x1 . stringValue . show++y1 :: D.Number -> Attribute+y1 = SVG.y1 . stringValue . show++x2 :: D.Number -> Attribute+x2 = SVG.x2 . stringValue . show++y2 :: D.Number -> Attribute+y2 = SVG.y2 . stringValue . show++xlinkHref :: D.IRI -> Attribute+xlinkHref = SVG.xlinkHref . stringValue . show++d :: String -> Attribute+d = SVG.d . stringValue++preserveaspectratio :: String -> Attribute+preserveaspectratio = SVG.preserveaspectratio . stringValue++fillOpacity :: D.OpacityValue -> Attribute+fillOpacity = SVG.fillOpacity . stringValue . showOpacityValue++strokeOpacity :: D.OpacityValue -> Attribute+strokeOpacity = SVG.strokeOpacity . stringValue . showOpacityValue++stopOpacity :: D.OpacityValue -> Attribute+stopOpacity = SVG.stopOpacity . stringValue . showOpacityValue++-- Contrary to the SVG 1.1 standard, WebKit doesn't handle scientific+-- notation in presentation attributes correctly. Use decimal notation.+showOpacityValue :: D.OpacityValue -> String+showOpacityValue = flip (showFFloat Nothing) ""
+ src/Text/Noise/SourceRange.hs view
@@ -0,0 +1,36 @@+module Text.Noise.SourceRange+( SourceRange+, HasSourceRange(..)+, oneLineRange+, zeroRange+, sourceName+, startLine+, startColumn+) where++import qualified Text.Parsec as Parsec+import qualified Text.Parsec.Pos as Parsec.Pos++type SourceRange = (Parsec.SourcePos, Parsec.SourcePos)++oneLineRange :: Parsec.SourceName -> Int -> Int -> SourceRange+oneLineRange name col len = ( Parsec.Pos.newPos name 1 col+ , Parsec.Pos.newPos name 1 (col + len))++zeroRange :: SourceRange+zeroRange = oneLineRange "" 1 0++sourceName :: SourceRange -> String+sourceName = Parsec.Pos.sourceName . fst++startLine :: SourceRange -> Parsec.Pos.Line+startLine = Parsec.Pos.sourceLine . fst++startColumn :: SourceRange -> Parsec.Pos.Column+startColumn = Parsec.Pos.sourceColumn . fst++class HasSourceRange a where+ rangeInSource :: a -> SourceRange++instance HasSourceRange Parsec.ParseError where+ rangeInSource err = (pos, pos) where pos = Parsec.errorPos err
+ tests/Main.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -F -pgmF htfpp -fno-warn-missing-signatures #-}++module Main where++import Test.Framework+import {-@ HTF_TESTS @-} Text.Noise.Compiler.Test+import {-@ HTF_TESTS @-} Text.Noise.Compiler.Builtin.Test+import {-@ HTF_TESTS @-} Text.Noise.Compiler.Document.Color.Test+import {-@ HTF_TESTS @-} Text.Noise.Parser.Test+import {-@ HTF_TESTS @-} Text.Noise.Parser.Character.Test++main = htfMain htf_importedTests