diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/noise.cabal b/noise.cabal new file mode 100644 --- /dev/null +++ b/noise.cabal @@ -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 +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 diff --git a/src-cli/Main.hs b/src-cli/Main.hs new file mode 100644 --- /dev/null +++ b/src-cli/Main.hs @@ -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 diff --git a/src/Text/Noise/Compiler.hs b/src/Text/Noise/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Compiler.hs @@ -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 diff --git a/src/Text/Noise/Compiler/Builtin.hs b/src/Text/Noise/Compiler/Builtin.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Compiler/Builtin.hs @@ -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 diff --git a/src/Text/Noise/Compiler/Document.hs b/src/Text/Noise/Compiler/Document.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Compiler/Document.hs @@ -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 } diff --git a/src/Text/Noise/Compiler/Document/Color.hs b/src/Text/Noise/Compiler/Document/Color.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Compiler/Document/Color.hs @@ -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 diff --git a/src/Text/Noise/Compiler/Error.hs b/src/Text/Noise/Compiler/Error.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Compiler/Error.hs @@ -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 diff --git a/src/Text/Noise/Compiler/Function.hs b/src/Text/Noise/Compiler/Function.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Compiler/Function.hs @@ -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 diff --git a/src/Text/Noise/Error.hs b/src/Text/Noise/Error.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Error.hs @@ -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" diff --git a/src/Text/Noise/Parser.hs b/src/Text/Noise/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Parser.hs @@ -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 diff --git a/src/Text/Noise/Parser/AST.hs b/src/Text/Noise/Parser/AST.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Parser/AST.hs @@ -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 diff --git a/src/Text/Noise/Parser/Character.hs b/src/Text/Noise/Parser/Character.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Parser/Character.hs @@ -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) diff --git a/src/Text/Noise/Parser/Language.hs b/src/Text/Noise/Parser/Language.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Parser/Language.hs @@ -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 } diff --git a/src/Text/Noise/Parser/Token.hs b/src/Text/Noise/Parser/Token.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Parser/Token.hs @@ -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 diff --git a/src/Text/Noise/Parser/Token/Internal.hs b/src/Text/Noise/Parser/Token/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Parser/Token/Internal.hs @@ -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) + } diff --git a/src/Text/Noise/Renderer.hs b/src/Text/Noise/Renderer.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Renderer.hs @@ -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] diff --git a/src/Text/Noise/Renderer/SVG/Attributes.hs b/src/Text/Noise/Renderer/SVG/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/Renderer/SVG/Attributes.hs @@ -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) "" diff --git a/src/Text/Noise/SourceRange.hs b/src/Text/Noise/SourceRange.hs new file mode 100644 --- /dev/null +++ b/src/Text/Noise/SourceRange.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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