diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/src/Yi/Config/Default/JavaScriptMode.hs b/src/Yi/Config/Default/JavaScriptMode.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Config/Default/JavaScriptMode.hs @@ -0,0 +1,10 @@ +module Yi.Config.Default.JavaScriptMode (configureJavaScriptMode) where + +import Lens.Micro.Platform ((%=)) +import Yi.Mode.JavaScript +import Yi.Config.Simple (ConfigM) +import Yi.Config.Lens (modeTableA) +import Yi.Types (AnyMode (..)) + +configureJavaScriptMode :: ConfigM () +configureJavaScriptMode = modeTableA %= (AnyMode (hooks javaScriptMode) :) diff --git a/src/Yi/Lexer/JavaScript.x b/src/Yi/Lexer/JavaScript.x new file mode 100644 --- /dev/null +++ b/src/Yi/Lexer/JavaScript.x @@ -0,0 +1,281 @@ +-- -*- haskell -*- +-- +-- Simple lexer for JavaScript 1.7 +-- (C) Copyright 2009 Deniz Dogan +-- +-- Note that this mode is for JavaScript 1.7, i.e. Mozilla, not ECMAScript, nor +-- JScript, but it does take much of its information from the ECMAScript +-- specification. +-- +-- Things about JavaScript deserve to be mentioned: +-- * JavaScript explicitly forbids nested comments, so we don't have to care +-- about the "level" of nesting in multiline comments +-- * JavaScript supports making variables for which the name clashes with +-- constructors, e.g. Array, but you cannot use "new Array()" to create an +-- array if you do that. +-- +-- Sources for reserved words: +-- https://developer.mozilla.org/En/Core_JavaScript_1.5_Reference/Reserved_Words +-- https://developer.mozilla.org/en/New_in_JavaScript_1.6 +-- https://developer.mozilla.org/en/New_in_JavaScript_1.7 +-- +-- Sources for the general syntax: +-- http://en.wikipedia.org/wiki/JavaScript_syntax +-- http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-262.pdf + +{ +#define NO_ALEX_CONTEXTS +{-# OPTIONS -w #-} + +module Yi.Lexer.JavaScript ( initState, alexScanToken, tokenToStyle, + TT, Token(..), Reserved(..), Operator(..), + HlState, prefixOperators, infixOperators, + postfixOperators ) where + +import Data.Monoid (Endo(..)) +import Yi.Lexer.Alex hiding (tokenToStyle) +import Yi.Style + +} + +$whitechar = [\ \t\n\r\f\v] + +@builtin = true | false | null | undefined +@reservedid = break | case | catch | continue | default | delete | do | else + | finally | for | function | if | in | instanceof | new | return + | switch | this | throw | try | typeof | var | void | while | with + | @builtin + +@ops = "+" | "-" | "*" | "/" | "%" | "++" | "--" | "=" | "+=" + | "-=" | "*=" | "/=" | "%=" | "==" | "!=" | ">" | ">=" | "<" + | "<=" | "===" | "!==" | "&&" |"||" | "!" | "&" | "|" | "^" + | "<<" | ">>" | ">>>" | "~" | "." + +$large = [A-Z \xc0-\xd6 \xd8-\xde] +$small = [a-z \xdf-\xf6 \xf8-\xff] +$special = [\(\)\,\;\[\]\{\}\:\?] + +$digit = 0-9 +$hexit = [0-9 A-F a-f] +@decimal = $digit+ +@hexal = "0x" $hexit+ + +$ascsymbol = [\!\#\$\%\&\*\+\.\/\<\=\>\@\\\^\|\-\~\_] +$unisymbol = [] -- TODO +$symbol = [$ascsymbol $unisymbol] # [$special \:\"\'] +$graphic = [$small $large $symbol $digit $special \:\"\'] +$name = [a-zA-Z0-9\_\$] -- Valid characters for a "name" + +-- Octals are sort of "implicit" in JavaScript. "0307" is a valid octal, but +-- "0309" is the exact same thing as "309." Since we don't make any distinction +-- between different types of numbers, we completely disregard octals here, they +-- Just Work (tm). +@number = @decimal | @hexal +@gap = \\ $whitechar +@string1 = $graphic # [\"\\] | " " | @gap +@string2 = $graphic # [\'\\] | " " | @gap + +-- @varid represents valid names for variables and functions. +@varid = [$name # [0-9A-Z]] $name* +@const = [$name # [0-9a-z]] $name* -- Constants and constructors + +haskell :- + +<0> { + +$whitechar+ ; +$special { cs $ (Special . head) } -- All of the special symbols are characters + +@number { cs $ Number } +@ops { cs $ (Op . opToOp) } +@reservedid { cs $ (Res . resToRes) } +@varid { cs $ ValidName } +@const { cs $ Const } + +\" @string1* \" { cs $ Str } +\' @string2* \' { cs $ Str } +\/ [^\/]+ \/ { cs $ Rex } +"//".* { c $ Comment Line } +"/*" { m (subtract 1) $ Comment Start } +"" { m (subtract 1) $ Comment End } +$whitechar+ ; +[^\-] { c $ Comment Text } +. { c $ Comment Text } +} + + +{ + +type TT = Tok Token + +-- | The @Line@ constructor represents a single-line comment. @Start@ and @End@ +-- represent the start and end of a multi-line comment, respectively. @Text@ +-- represents the text in a multi-line comment. +data CommentType = Line | Start | End | Text + deriving (Show, Eq) + +-- | The constructors for @Reserved@ have an apostrophe as a suffix because +-- @Default@ is already used. Also note that @Undefined'@ is not intended as +-- some sort of "backup" reserved word for things we don't care about -- it +-- really means the "undefined" built-in in JavaScript. +data Reserved = Break' | Case' | Catch' | Continue' | Default' | Delete' | Do' + | Else' | Finally' | For' | Function' | If' | In' | InstanceOf' + | New' | Return' | Switch' | This' | Throw' | Try' | TypeOf' + | Var' | Void' | While' | With' | True' | False' | Null' + | Undefined' + deriving (Show, Eq) + +-- | The constructors for @Operator@ have an apostrophe as a suffix because +-- e.g. @LT@ is already used by @Prelude@. +data Operator = Add' | Subtract' | Multiply' | Divide' | Modulo' | Increment' + | Decrement' | Assign' | AddAssign' | SubtractAssign' + | MultiplyAssign' | DivideAssign' | ModuloAssign' | Equals' + | NotEquals' | GT' | GTE' | LT' | LTE' | EqualsType' + | NotEqualsType' | And' | Or' | Not' | BitAnd' | BitOr' | BitXor' + | LeftShift' | RightShift' | RightShiftZ' | BitNot' | Qualify' + deriving (Show, Eq) + +-- | Prefix operators. NOTE: Add' is also a valid prefix operator, but since +-- it's completely useless in the real world, we don't care about it here. +-- Doing this makes parsing much, much easier. +prefixOperators = [ Subtract', Increment', Decrement', BitNot', Not' ] + +-- | Postfix operators. +postfixOperators = [ Increment', Decrement' ] + +-- | Infix operators. +infixOperators = [ Add', Subtract', Multiply', Divide', Modulo', Assign', + AddAssign', SubtractAssign', MultiplyAssign', DivideAssign', + ModuloAssign', Equals', NotEquals', GT', GTE', LT', LTE', + EqualsType', NotEqualsType', And', Or', BitAnd', BitOr', + BitXor', LeftShift', RightShift', RightShiftZ', Qualify' ] + +-- | @HlState@ is 0 when outside of a multi-line comment and -1 when inside one. +type HlState = Int + +-- | The different tokens. +data Token = Unknown + | Res !Reserved + | Str !String + | Rex !String + | Op !Operator + | Special !Char + | Number !String + | ValidName !String + | Comment !CommentType + | Const !String + deriving (Show, Eq) + +stateToInit x | x < 0 = multicomm + | x > 0 = htmlcomm + | otherwise = 0 + +initState :: HlState +initState = 0 + +-- | Takes a 'Token' and returns a style to be used for that type of token. +-- +-- TODO: The `elem` check is potentially unnecessarily slow. We could split +-- the Const constructor into two different ones, one for builtins and one for +-- others. +tokenToStyle (Comment Line) = commentStyle +tokenToStyle (Comment _) = blockCommentStyle +tokenToStyle (Const x) | x `elem` builtinConstructors = builtinStyle + | otherwise = typeStyle +tokenToStyle (Number _) = numberStyle +tokenToStyle (Res _) = keywordStyle +tokenToStyle (Str _) = stringStyle +tokenToStyle (Rex _) = regexStyle +tokenToStyle Unknown = errorStyle +tokenToStyle _ = defaultStyle + +builtinConstructors :: [String] +builtinConstructors = [ "Array", "String", "RegExp", "Function", "Date" + , "Boolean", "Object" ] + +-- | Given a @String@ representing an operator, returns an 'Operator' with the +-- appropriate constructor. +opToOp :: String -> Operator +opToOp "+" = Add' +opToOp "-" = Subtract' +opToOp "*" = Multiply' +opToOp "/" = Divide' +opToOp "%" = Modulo' +opToOp "++" = Increment' +opToOp "--" = Decrement' +opToOp "=" = Assign' +opToOp "+=" = AddAssign' +opToOp "-=" = SubtractAssign' +opToOp "*=" = MultiplyAssign' +opToOp "/=" = DivideAssign' +opToOp "%=" = ModuloAssign' +opToOp "==" = Equals' +opToOp "!=" = NotEquals' +opToOp ">" = GT' +opToOp ">=" = GTE' +opToOp "<" = LT' +opToOp "<=" = LTE' +opToOp "===" = EqualsType' +opToOp "!==" = NotEqualsType' +opToOp "&&" = And' +opToOp "||" = Or' +opToOp "!" = Not' +opToOp "&" = BitAnd' +opToOp "|" = BitOr' +opToOp "^" = BitXor' +opToOp "<<" = LeftShift' +opToOp ">>" = RightShift' +opToOp ">>>" = RightShiftZ' +opToOp "~" = BitNot' +opToOp "." = Qualify' + +-- | Given a @String@ representing a reserved word, returns a 'Reserved' with +-- the appropriate constructor. +resToRes :: String -> Reserved +resToRes "break" = Break' +resToRes "case" = Case' +resToRes "catch" = Catch' +resToRes "continue" = Continue' +resToRes "default" = Default' +resToRes "delete" = Delete' +resToRes "do" = Do' +resToRes "else" = Else' +resToRes "finally" = Finally' +resToRes "for" = For' +resToRes "function" = Function' +resToRes "if" = If' +resToRes "in" = In' +resToRes "instanceof" = InstanceOf' +resToRes "new" = New' +resToRes "return" = Return' +resToRes "switch" = Switch' +resToRes "this" = This' +resToRes "throw" = Throw' +resToRes "try" = Try' +resToRes "typeof" = TypeOf' +resToRes "var" = Var' +resToRes "void" = Void' +resToRes "while" = While' +resToRes "with" = With' +resToRes "true" = True' +resToRes "false" = False' +resToRes "null" = Null' +resToRes "undefined" = Undefined' + +#include "common.hsinc" + +} diff --git a/src/Yi/Mode/JavaScript.hs b/src/Yi/Mode/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Mode/JavaScript.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Yi.Mode.JavaScript +-- License : GPL-2 +-- Maintainer : yi-devel@googlegroups.com +-- Stability : experimental +-- Portability : portable +-- +-- Module defining the 'Mode' for JavaScript. 'javaScriptMode' uses +-- the parser defined at "Yi.Syntax.JavaScript". + +module Yi.Mode.JavaScript (javaScriptMode, hooks) where + +import Lens.Micro.Platform ((%~)) +import Control.Monad.Writer.Lazy (execWriter) +import Data.Binary (Binary) +import Data.Default (Default) +import Data.DList as D (toList) +import Data.Foldable as F (toList) +import Data.List (nub) +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import qualified Data.Text as T (unlines) +import Data.Typeable (Typeable) +import System.FilePath.Posix (takeBaseName) +import Yi.Buffer +import Yi.Core (withSyntax) +import Yi.Editor +import Yi.Event (Event (..), Key (..)) +import Yi.File (fwriteE) +import Yi.IncrementalParse (scanner) +import Yi.Interact (choice) +import Yi.Keymap (Action (..), YiM, topKeymapA) +import Yi.Keymap.Keys (ctrlCh, important, (?>>), (?>>!)) +import Yi.Lexer.Alex (AlexState, CharScanner, Tok, commonLexer, lexScanner) +import Yi.Lexer.JavaScript (HlState, TT, Token, alexScanToken, initState) +import Yi.Mode.Common (anyExtension) +import Yi.Monad (gets) +import qualified Yi.Rope as R (fromString, fromText) +import Yi.String (showT) +import Yi.Syntax (ExtHL (..), Scanner, mkHighlighter) +import Yi.Syntax.JavaScript (Tree, getStrokes, parse) +import Yi.Syntax.Tree (getLastPath) +import Yi.Types (YiVariable) +import Yi.Verifier.JavaScript (verify) + +javaScriptAbstract :: Mode syntax +javaScriptAbstract = emptyMode + { modeApplies = anyExtension ["js"] + , modeName = "javascript" + , modeToggleCommentSelection = Just (toggleCommentB "//") + } + +javaScriptMode :: Mode (Tree TT) +javaScriptMode = javaScriptAbstract + { modeIndent = jsSimpleIndent + , modeHL = ExtHL $ mkHighlighter (scanner parse . jsLexer) + , modeGetStrokes = getStrokes + } + +jsSimpleIndent :: Tree TT -> IndentBehaviour -> BufferM () +jsSimpleIndent t behave = do + indLevel <- shiftWidth <$> indentSettingsB + prevInd <- getNextNonBlankLineB Backward >>= indentOfB + solPnt <- pointAt moveToSol + let path = getLastPath (F.toList t) solPnt + case path of + Nothing -> indentTo [indLevel, 0] + Just _ -> indentTo [prevInd, + prevInd + indLevel, + prevInd - indLevel] + where + -- Given a list of possible columns to indent to, removes any + -- duplicates from it and cycles between the resulting + -- indentations. + indentTo :: [Int] -> BufferM () + indentTo = cycleIndentsB behave . nub + +jsLexer :: CharScanner -> Scanner (AlexState HlState) (Tok Token) +jsLexer = lexScanner (commonLexer alexScanToken initState) + +-------------------------------------------------------------------------------- + +-- tta :: Yi.Lexer.Alex.Tok Token -> Maybe (Yi.Syntax.Span String) +-- tta = sequenceA . tokToSpan . (fmap Main.tokenToText) + +-- | Hooks for the JavaScript mode. +hooks :: Mode (Tree TT) -> Mode (Tree TT) +hooks mode = mode + { modeKeymap = topKeymapA %~ important (choice m) + , modeFollow = YiA . jsCompile + } + where + m = [ ctrlCh 'c' ?>> ctrlCh 'l' ?>>! withSyntax modeFollow + , Event KEnter [] ?>>! newlineAndIndentB + ] + +newtype JSBuffer = JSBuffer (Maybe BufferRef) + deriving (Default, Typeable, Binary) + +instance YiVariable JSBuffer + +-- | The "compiler." +jsCompile :: Tree TT -> YiM () +jsCompile tree = do + _ <- fwriteE + Just filename <- withCurrentBuffer $ gets file + buf <- getJSBuffer + withOtherWindow $ withEditor $ switchToBufferE buf + jsErrors filename buf (D.toList $ execWriter $ verify tree) + +-- | Returns the JS verifier buffer, creating it if necessary. +getJSBuffer :: YiM BufferRef +getJSBuffer = withOtherWindow $ do + JSBuffer mb <- withEditor getEditorDyn + case mb of + Nothing -> mkJSBuffer + Just b -> do stillExists <- isJust <$> findBuffer b + if stillExists + then return b + else mkJSBuffer + +-- | Creates a new empty buffer and returns it. +mkJSBuffer :: YiM BufferRef +mkJSBuffer = stringToNewBuffer (MemBuffer "js") mempty + +-- | Given a filename, a BufferRef and a list of errors, prints the +-- errors in that buffer. +jsErrors :: Show a => String -> BufferRef -> [a] -> YiM () +jsErrors fname buf errs = + let problems = T.unlines $ map item errs + item x = "* " <> showT x + str = if null errs + then "No problems found!" + else "Problems in " + <> R.fromString (takeBaseName fname) + <> ":\n" <> R.fromText problems + in withGivenBuffer buf (replaceBufferContent str) diff --git a/src/Yi/Syntax/JavaScript.hs b/src/Yi/Syntax/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Syntax/JavaScript.hs @@ -0,0 +1,590 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} + +-- | +-- Module : Yi.Syntax.JavaScript +-- License : GPL-2 +-- Maintainer : yi-devel@googlegroups.com +-- Stability : experimental +-- Portability : portable +-- +-- Parser for the JavaScript language as described at +-- . +-- +-- The mode using this parser can be found at "Yi.Mode.JavaScript". + +module Yi.Syntax.JavaScript where + +import Prelude hiding (elem,error,any,exp) + +import Control.Applicative (Alternative ((<|>), many), optional) +import Data.Data (Data) +import Data.Foldable (any, elem, toList) +import Data.Monoid (Endo (..), (<>)) +import qualified Data.Text as T (cons) +import Data.Typeable (Typeable) +import Yi.Buffer.Basic (Point (..)) +import Yi.Debug (trace) +import Yi.IncrementalParse (P, eof, recoverWith, symbol) +import Yi.Lexer.Alex (Stroke, Tok (..), tokFromT, tokToSpan) +import Yi.Lexer.JavaScript +import Yi.String (showT) +import Yi.Style (StyleName, errorStyle) +import Yi.Syntax.Tree (IsTree (..), sepBy, sepBy1) + +-- * Data types, classes and instances + +-- | Instances of @Strokable@ are datatypes which can be syntax highlighted. +class Strokable a where + toStrokes :: a -> Endo [Stroke] + +-- | Instances of @Failable@ can represent failure. This is a useful class for +-- future work, since then we can make stroking much easier. +class Failable f where + stupid :: t -> f t + hasFailed :: f t -> Bool + +type BList a = [a] + +type Tree t = BList (Statement t) + +type Semicolon t = Maybe t + +data Statement t = FunDecl t t (Parameters t) (Block t) + | VarDecl t (BList (VarDecAss t)) (Semicolon t) + | Return t (Maybe (Expr t)) (Semicolon t) + | While t (ParExpr t) (Block t) + | DoWhile t (Block t) t (ParExpr t) (Semicolon t) + | For t t (Expr t) (ForContent t) t (Block t) + | If t (ParExpr t) (Block t) (Maybe (Statement t)) + | Else t (Block t) + | With t (ParExpr t) (Block t) + | Comm t + | Expr (Expr t) (Semicolon t) + deriving (Show, Data, Typeable, Foldable) + +data Parameters t = Parameters t (BList t) t + | ParErr t + deriving (Show, Data, Typeable, Foldable) + +data ParExpr t = ParExpr t (BList (Expr t)) t + | ParExprErr t + deriving (Show, Data, Typeable, Foldable) + +data ForContent t = ForNormal t (Expr t) t (Expr t) + | ForIn t (Expr t) + | ForErr t + deriving (Show, Data, Typeable, Foldable) + +data Block t = Block t (BList (Statement t)) t + | BlockOne (Statement t) + | BlockErr t + deriving (Show, Data, Typeable, Foldable) + +-- | Represents either a variable name or a variable name assigned to an +-- expression. @AssBeg@ is a variable name /maybe/ followed by an assignment. +-- @AssRst@ is an equals sign and an expression. @(AssBeg 'x' (Just (AssRst +-- '=' '5')))@ means @x = 5@. +data VarDecAss t = AssBeg t (Maybe (VarDecAss t)) + | AssRst t (Expr t) + | AssErr t + deriving (Show, Data, Typeable, Foldable) + +data Expr t = ExprObj t (BList (KeyValue t)) t + | ExprPrefix t (Expr t) + | ExprNew t (Expr t) + | ExprSimple t (Maybe (Expr t)) + | ExprParen t (Expr t) t (Maybe (Expr t)) + | ExprAnonFun t (Parameters t) (Block t) + | ExprTypeOf t (Expr t) + | ExprFunCall t (ParExpr t) (Maybe (Expr t)) + | OpExpr t (Expr t) + | ExprCond t (Expr t) t (Expr t) + | ExprArr t (Maybe (Array t)) t (Maybe (Expr t)) + | PostExpr t + | ExprErr t + deriving (Show, Data, Typeable, Foldable) + +data Array t = ArrCont (Expr t) (Maybe (Array t)) + | ArrRest t (Array t) (Maybe (Array t)) + | ArrErr t + deriving (Show, Data, Typeable, Foldable) + +data KeyValue t = KeyValue t t (Expr t) + | KeyValueErr t + deriving (Show, Data, Typeable, Foldable) + + +instance IsTree Statement where + subtrees (FunDecl _ _ _ x) = fromBlock x + subtrees (While _ _ x) = fromBlock x + subtrees (DoWhile _ x _ _ _) = fromBlock x + subtrees (For _ _ _ _ _ x) = fromBlock x + subtrees (If _ _ x mb) = fromBlock x <> maybe [] subtrees mb + subtrees (Else _ x) = fromBlock x + subtrees (With _ _ x) = fromBlock x + subtrees _ = [] + +instance Failable ForContent where + stupid = ForErr + hasFailed t = case t of + ForErr _ -> True + _ -> False + +instance Failable Block where + stupid = BlockErr + hasFailed t = case t of + BlockErr _ -> True + _ -> False + +instance Failable VarDecAss where + stupid = AssErr + hasFailed t = case t of + AssErr _ -> True + _ -> False + +instance Failable Parameters where + stupid = ParErr + hasFailed t = case t of + ParErr _ -> True + _ -> False + +instance Failable ParExpr where + stupid = ParExprErr + hasFailed t = case t of + ParExprErr _ -> True + _ -> False + +instance Failable Expr where + stupid = ExprErr + hasFailed t = case t of + ExprErr _ -> True + _ -> False + +instance Failable KeyValue where + stupid = KeyValueErr + hasFailed t = case t of + KeyValueErr _ -> True + _ -> False + + +-- | TODO: This code is *screaming* for some generic programming. +-- +-- TODO: Somehow fix Failable and failStroker to be more "generic". This will +-- make these instances much nicer and we won't have to make ad-hoc stuff like +-- this. +instance Strokable (Statement TT) where + toStrokes (FunDecl f n ps blk) = + let s = if hasFailed blk then error else failStroker [n] in + s f <> s n <> toStrokes ps <> toStrokes blk + toStrokes (VarDecl v vs sc) = + let s = if any hasFailed vs then error else normal in + s v <> foldMap toStrokes vs <> maybe mempty s sc + toStrokes (Return t exp sc) = normal t <> maybe mempty toStrokes exp <> maybe mempty normal sc + toStrokes (While w exp blk) = + let s = if hasFailed blk || hasFailed blk then error else normal in + s w <> toStrokes exp <> toStrokes blk + toStrokes (DoWhile d blk w exp sc) = + let s1 = if hasFailed blk then error else normal + s2 = if hasFailed exp then error else normal in + s1 d <> toStrokes blk <> s2 w <> toStrokes exp <> maybe mempty normal sc + toStrokes (For f l x c r blk) = + let s = if hasFailed blk || hasFailed c || hasFailed x + then error + else failStroker [f, l, r] in + s f <> s l <> toStrokes x <> toStrokes c <> s r <> toStrokes blk + toStrokes (If i x blk e) = + let s = if hasFailed blk then error else normal in + s i <> toStrokes x <> toStrokes blk <> maybe mempty toStrokes e + toStrokes (Else e blk) = normal e <> toStrokes blk + toStrokes (With w x blk) = normal w <> toStrokes x <> toStrokes blk + toStrokes (Expr exp sc) = toStrokes exp <> maybe mempty normal sc + toStrokes (Comm t) = normal t + +instance Strokable (ForContent TT) where + toStrokes (ForNormal s1 x2 s2 x3) = + let s = if any hasFailed [x2, x3] then error else failStroker [s2] in + s s1 <> toStrokes x2 <> s s2 <> toStrokes x3 + toStrokes (ForIn i x) = + let s = if hasFailed x then error else normal in + s i <> toStrokes x + toStrokes (ForErr t) = error t + +instance Strokable (Block TT) where + toStrokes (BlockOne stmt) = toStrokes stmt + toStrokes (Block l stmts r) = + let s = failStroker [l, r] in + s l <> foldMap toStrokes stmts <> s r + toStrokes (BlockErr t) = error t + +instance Strokable (VarDecAss TT) where + toStrokes (AssBeg t x) = normal t <> maybe mempty toStrokes x + toStrokes (AssRst t exp) = + let s = if hasFailed exp then error else normal in + s t <> toStrokes exp + toStrokes (AssErr t) = error t + +instance Strokable (Expr TT) where + toStrokes (ExprSimple x exp) = normal x <> maybe mempty toStrokes exp + toStrokes (ExprObj l kvs r) = + let s = failStroker [l, r] in + s l <> foldMap toStrokes kvs <> s r + toStrokes (ExprPrefix t exp) = normal t <> toStrokes exp + toStrokes (ExprNew t x) = normal t <> toStrokes x + toStrokes (ExprParen l exp r op) = + let s = failStroker [l, r] in + s l <> toStrokes exp <> s r <> maybe mempty toStrokes op + toStrokes (ExprAnonFun f ps blk) = + normal f <> toStrokes ps <> toStrokes blk + toStrokes (ExprTypeOf t x) = + let s = if hasFailed x then error else normal in + s t <> toStrokes x + toStrokes (ExprFunCall n x m) = + let s = if hasFailed x then error else normal in + s n <> toStrokes x <> maybe mempty toStrokes m + toStrokes (OpExpr op exp) = + let s = if hasFailed exp then error else normal in + s op <> toStrokes exp + toStrokes (PostExpr t) = normal t + toStrokes (ExprCond a x b y) = + let s = failStroker [a, b] in + s a <> toStrokes x <> s b <> toStrokes y + toStrokes (ExprArr l x r m) = + let s = failStroker [l, r] in + s l <> maybe mempty toStrokes x <> s r <> maybe mempty toStrokes m + toStrokes (ExprErr t) = error t + +instance Strokable (Parameters TT) where + toStrokes (Parameters l ps r) = normal l <> foldMap toStrokes ps <> normal r + toStrokes (ParErr t) = error t + +instance Strokable (ParExpr TT) where + toStrokes (ParExpr l xs r) = + let s = if isError r || any hasFailed xs + then error + else normal in + s l <> foldMap toStrokes xs <> s r + toStrokes (ParExprErr t) = error t + +instance Strokable (KeyValue TT) where + toStrokes (KeyValue n c exp) = + let s = failStroker [n, c] in + s n <> s c <> toStrokes exp + toStrokes (KeyValueErr t) = error t + +instance Strokable (Tok Token) where + toStrokes t = if isError t + then one (modStroke errorStyle . tokenToStroke) t + else one tokenToStroke t + +instance Strokable (Array TT) where + toStrokes (ArrCont x m) = toStrokes x <> maybe mempty toStrokes m + toStrokes (ArrRest c a m) = normal c <> toStrokes a <> maybe mempty toStrokes m + toStrokes (ArrErr t) = error t + + +-- * Helper functions. + +-- | Normal stroker. +normal :: TT -> Endo [Stroke] +normal = one tokenToStroke + +-- | Error stroker. +error :: TT -> Endo [Stroke] +error = one (modStroke errorStyle . tokenToStroke) + +one :: (t -> a) -> t -> Endo [a] +one f x = Endo (f x :) + +-- | Given a new style and a stroke, return a stroke with the new style appended +-- to the old one. +modStroke :: StyleName -> Stroke -> Stroke +modStroke style = fmap (style <>) + + +-- * Stroking functions + +-- | Given a list of tokens to check for errors (@xs@) and a list of tokens to +-- stroke (@xs'@), returns normal strokes for @xs'@ if there were no errors. +-- Otherwise returns error strokes for @xs'@. +nError :: [TT] -> [TT] -> Endo [Stroke] +nError xs = foldMap (failStroker xs) + +-- | Given a list of @TT@, if any of them is an error, returns an error stroker, +-- otherwise a normal stroker. Using e.g. existentials, we could make this +-- more general and have support for heterogeneous lists of elements which +-- implement Failable, but I haven't had the time to fix this. +failStroker :: [TT] -> TT -> Endo [Stroke] +failStroker xs = if any isError xs then error else normal + +-- | Given a @TT@, return a @Stroke@ for it. +tokenToStroke :: TT -> Stroke +tokenToStroke = fmap tokenToStyle . tokToSpan + +-- | The main stroking function. +getStrokes :: Tree TT -> Point -> Point -> Point -> [Stroke] +getStrokes t0 _point _begin _end = trace ('\n' `T.cons` showT t0) result + where + result = appEndo (foldMap toStrokes t0) [] + + +-- * The parser + +-- | Main parser. +parse :: P TT (Tree TT) +parse = many statement <* eof + +-- | Parser for statements such as "return", "while", "do-while", "for", etc. +statement :: P TT (Statement TT) +statement = FunDecl <$> res Function' <*> plzTok name <*> parameters <*> block + <|> VarDecl <$> res Var' <*> plz varDecAss `sepBy1` spc ',' <*> semicolon + <|> Return <$> res Return' <*> optional expression <*> semicolon + <|> While <$> res While' <*> parExpr <*> block + <|> DoWhile <$> res Do' <*> block <*> plzTok (res While') <*> parExpr <*> semicolon + <|> For <$> res For' <*> plzSpc '(' <*> plzExpr <*> forContent + <*> plzSpc ')' <*> block + <|> If <$> res If' <*> parExpr <*> block <*> optional (Else <$> res Else' <*> block) + <|> With <$> res With' <*> parExpr <*> block + <|> Comm <$> comment + <|> Expr <$> stmtExpr <*> semicolon + where + forContent :: P TT (ForContent TT) + forContent = ForNormal <$> spc ';' <*> plzExpr <*> plzSpc ';' <*> plzExpr + <|> ForIn <$> res In' <*> plzExpr + <|> ForErr <$> hate 1 (symbol (const True)) + <|> ForErr <$> hate 2 (pure errorToken) + varDecAss :: P TT (VarDecAss TT) + varDecAss = AssBeg <$> name <*> optional (AssRst <$> oper Assign' <*> plzExpr) + +-- | Parser for "blocks", i.e. a bunch of statements wrapped in curly brackets +-- /or/ just a single statement. +-- +-- Note that this works for JavaScript 1.8 "lambda" style function bodies as +-- well, e.g. "function hello() 5", since expressions are also statements and +-- we don't require a trailing semi-colon. +-- +-- TODO: function hello() var x; is not a valid program. +block :: P TT (Block TT) +block = Block <$> spc '{' <*> many statement <*> plzSpc '}' + <|> BlockOne <$> hate 1 statement + <|> BlockErr <$> hate 2 (pure errorToken) + +-- | Parser for expressions which may be statements. In reality, any expression +-- is also a valid statement, but this is a slight compromise to get rid of +-- the massive performance loss which is introduced when allowing JavaScript +-- objects to be valid statements. +stmtExpr :: P TT (Expr TT) +stmtExpr = ExprSimple <$> simpleTok <*> optional opExpr + <|> ExprPrefix <$> preOp <*> plzExpr + <|> ExprNew <$> res New' <*> plz funCall + <|> funCall + -- We hate the parenthesized expression just a tad because otherwise + -- confirm('hello') will be seen as "confirm; ('hello');" + <|> hate 1 (ExprParen <$> spc '(' <*> plzExpr <*> plzSpc ')' + <*> optional opExpr) + <|> ExprErr <$> hate 2 (symbol (const True)) + where + funCall :: P TT (Expr TT) + funCall = ExprFunCall <$> name <*> parExpr <*> optional opExpr + +-- | The basic idea here is to parse "the rest" of expressions, e.g. @+ 3@ in @x +-- + 3@ or @[i]@ in @x[i]@. Anything which is useful in such a scenario goes +-- here. TODO: This accepts [], but shouldn't, since x[] is invalid. +opExpr :: P TT (Expr TT) +opExpr = OpExpr <$> inOp <*> plzExpr + <|> ExprCond <$> spc '?' <*> plzExpr <*> plzSpc ':' <*> plzExpr + <|> PostExpr <$> postOp + <|> array + +-- | Parser for expressions. +expression :: P TT (Expr TT) +expression = ExprObj <$> spc '{' <*> keyValue `sepBy` spc ',' <*> plzSpc '}' + <|> ExprAnonFun <$> res Function' <*> parameters <*> block + <|> ExprTypeOf <$> res TypeOf' <*> plzExpr + <|> stmtExpr + <|> array + where + keyValue :: P TT (KeyValue TT) + keyValue = KeyValue <$> name <*> plzSpc ':' <*> plzExpr + <|> KeyValueErr <$> hate 1 (symbol (const True)) + <|> KeyValueErr <$> hate 2 (pure errorToken) + +-- | Parses both empty and non-empty arrays. Should probably be split up into +-- further parts to allow for the separation of @[]@ and @[1, 2, 3]@. +array :: P TT (Expr TT) +array = ExprArr <$> spc '[' <*> optional arrayContents <*> plzSpc ']' + <*> optional opExpr + where + arrayContents :: P TT (Array TT) + arrayContents = ArrCont <$> expression <*> optional arrRest + arrRest :: P TT (Array TT) + arrRest = ArrRest <$> spc ',' <*> (arrayContents + <|> ArrErr <$> hate 1 (symbol (const True)) + <|> ArrErr <$> hate 2 (pure errorToken)) + <*> optional arrRest + + +-- * Parsing helpers + +-- | Parses a semicolon if it's there. +semicolon :: P TT (Maybe TT) +semicolon = optional $ spc ';' + +-- | Parses a comma-separated list of valid identifiers. +parameters :: P TT (Parameters TT) +parameters = Parameters <$> spc '(' <*> plzTok name `sepBy` spc ',' <*> plzSpc ')' + <|> ParErr <$> hate 1 (symbol (const True)) + <|> ParErr <$> hate 2 (pure errorToken) + +parExpr :: P TT (ParExpr TT) +parExpr = ParExpr <$> spc '(' <*> plzExpr `sepBy` spc ',' <*> plzSpc ')' + <|> ParExprErr <$> hate 1 (symbol (const True)) + <|> ParExprErr <$> hate 2 (pure errorToken) + + +-- * Simple parsers + +-- | Parses a comment. +comment :: P TT TT +comment = symbol (\t -> case fromTT t of + Comment _ -> True + _ -> False) + +-- | Parses a prefix operator. +preOp :: P TT TT +preOp = symbol (\t -> case fromTT t of + Op x -> x `elem` prefixOperators + _ -> False) + +-- | Parses a infix operator. +inOp :: P TT TT +inOp = symbol (\t -> case fromTT t of + Op x -> x `elem` infixOperators + _ -> False) + +-- | Parses a postfix operator. +postOp :: P TT TT +postOp = symbol (\t -> case fromTT t of + Op x -> x `elem` postfixOperators + _ -> False) + +-- | Parses any literal. +opTok :: P TT TT +opTok = symbol (\t -> case fromTT t of + Op _ -> True + _ -> False) + +-- | Parses any literal. +simpleTok :: P TT TT +simpleTok = symbol (\t -> case fromTT t of + Str _ -> True + Number _ -> True + ValidName _ -> True + Const _ -> True + Rex _ -> True + Res y -> y `elem` [True', False', Undefined', Null', This'] + _ -> False) + +-- | Parses any string. +strTok :: P TT TT +strTok = symbol (\t -> case fromTT t of + Str _ -> True + _ -> False) + +-- | Parses any valid number. +numTok :: P TT TT +numTok = symbol (\t -> case fromTT t of + Number _ -> True + _ -> False) + +-- | Parses any valid identifier. +name :: P TT TT +name = symbol (\t -> case fromTT t of + ValidName _ -> True + Const _ -> True + _ -> False) + +-- | Parses any boolean. +boolean :: P TT TT +boolean = symbol (\t -> case fromTT t of + Res y -> y `elem` [True', False'] + _ -> False) + +-- | Parses a reserved word. +res :: Reserved -> P TT TT +res x = symbol (\t -> case fromTT t of + Res y -> x == y + _ -> False) + +-- | Parses a special token. +spc :: Char -> P TT TT +spc x = symbol (\t -> case fromTT t of + Special y -> x == y + _ -> False) + +-- | Parses an operator. +oper :: Operator -> P TT TT +oper x = symbol (\t -> case fromTT t of + Op y -> y == x + _ -> False) + + +-- * Recovery parsers + +-- | Expects a token x, recovers with 'errorToken'. +plzTok :: P TT TT -> P TT TT +plzTok x = x + <|> hate 1 (symbol (const True)) + <|> hate 2 (pure errorToken) + +-- | Expects a special token. +plzSpc :: Char -> P TT TT +plzSpc x = plzTok (spc x) + +-- | Expects an expression. +plzExpr :: P TT (Expr TT) +plzExpr = plz expression + +plz :: Failable f => P TT (f TT) -> P TT (f TT) +plz x = x + <|> stupid <$> hate 1 (symbol (const True)) + <|> stupid <$> hate 2 (pure errorToken) + +-- | General recovery parser, inserts an error token. +anything :: P s TT +anything = recoverWith (pure errorToken) + +-- | Weighted recovery. +hate :: Int -> P s a -> P s a +hate n = power n recoverWith + where + power 0 _ = id + power m f = f . power (m - 1) f + + +-- * Utility stuff + +fromBlock :: Block t -> [Statement t] +fromBlock (Block _ x _) = toList x +fromBlock (BlockOne x) = [x] +fromBlock (BlockErr _) = [] + +firstTok :: Foldable f => f t -> t +firstTok x = head (toList x) + +errorToken :: TT +errorToken = toTT $ Special '!' + +isError :: TT -> Bool +isError (Tok (Special '!') _ _) = True +isError _ = False + +-- | Better name for 'tokFromT'. +toTT :: t -> Tok t +toTT = tokFromT + +-- | Better name for 'tokT'. +fromTT :: Tok t -> t +fromTT = tokT diff --git a/src/Yi/Verifier/JavaScript.hs b/src/Yi/Verifier/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Yi/Verifier/JavaScript.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + +-- TODO: +-- ! User configuration. +-- ! Checking for side-effect-less code, e.g. "1;". + +module Yi.Verifier.JavaScript where + +import Control.Monad (unless) +import Control.Monad.Writer.Lazy (MonadWriter, Writer, tell) +import qualified Data.DList as D (DList, singleton) +import Data.Foldable (toList) +import Data.Function (on) +import Data.List (intercalate) +import Yi.Lexer.Alex (Posn, Tok, tokPosn, tokT) +import Yi.Lexer.JavaScript (TT, Token (..)) +import Yi.Syntax.JavaScript hiding (res) + + +-- * Types + +data Error = MultipleFunctionDeclaration String [Posn] + deriving Eq + +data Warning = UnreachableCode Posn + deriving Eq + +data Report = Err Error + | Warn Warning + deriving Eq + + +-- * Instances + +instance Show Error where + show (MultipleFunctionDeclaration n ps) = + "Function `" ++ n ++ "' declared more than once: " ++ intercalate ", " (map show ps) + +instance Show Warning where + show (UnreachableCode pos) = + "Unreachable code at " ++ show pos + +instance Show Report where + show (Err e) = "EE " ++ show e + show (Warn w) = "WW " ++ show w + + +-- * Main code + +-- | The main verifier which calls the sub-verifiers. +verify :: Tree TT -> Writer (D.DList Report) () +verify t = do + let topfuns = findFunctions (toList t) + checkMultipleFuns topfuns + mapM_ (checkUnreachable . funBody) topfuns + +-- | Given a list of function declarations, checks for multiple function +-- declarations, including the functions' subfunctions. +checkMultipleFuns :: [Statement TT] -> Writer (D.DList Report) () +checkMultipleFuns stmts = do + let dupFuns = dupsBy (ttEq `on` funName) stmts + unless (null dupFuns) + (say (Err (MultipleFunctionDeclaration + (nameOf $ tokT $ funName $ head dupFuns) + (map (tokPosn . funName) dupFuns)))) + let subFuns = map (findFunctions . funBody) (findFunctions stmts) + mapM_ checkMultipleFuns subFuns + +checkUnreachable :: [Statement TT] -> Writer (D.DList Report) () +checkUnreachable stmts = do + let afterReturn = dropWhile' (not . isReturn) stmts + unless (null afterReturn) + (say (Warn (UnreachableCode (tokPosn $ firstTok $ head afterReturn)))) + + +-- * Helper functions + +-- | Given two @Tok t@, compares the @t@s. +ttEq :: Eq t => Tok t -> Tok t -> Bool +ttEq x y = tokT x == tokT y + +say :: MonadWriter (D.DList a) m => a -> m () +say = tell . D.singleton + +isReturn :: Statement t -> Bool +isReturn (Return {}) = True +isReturn _ = False + +-- | Returns a list of the functions in the given block. +findFunctions :: [Statement t] -> [Statement t] +findFunctions stmts = [ f | f@(FunDecl {}) <- stmts ] + +-- | Given a 'FunDecl', returns the token representing the name. +funName :: Statement t -> t +funName (FunDecl _ n _ _) = n +funName _ = undefined + +-- | Given a 'FunDecl', returns its inner body as a list. +funBody :: Statement t -> [Statement t] +funBody (FunDecl _ _ _ blk) = + case blk of + Block _ stmts _ -> toList stmts + BlockOne stmt -> [stmt] + _ -> [] +funBody _ = undefined + +-- | Given a @ValidName@ returns the string representing the name. +nameOf :: Token -> String +nameOf (ValidName n) = n +nameOf _ = undefined + + +-- * Misc + +-- | Like 'dropWhile' but drops the first element in the result. +dropWhile' :: (a -> Bool) -> [a] -> [a] +dropWhile' p xs = + let res = dropWhile p xs in + if null res then [] else drop 1 res + +dupsBy :: (a -> a -> Bool) -> [a] -> [a] +dupsBy p xs = filter (\x -> length (filter (p x) xs) > 1) xs + diff --git a/yi-mode-javascript.cabal b/yi-mode-javascript.cabal new file mode 100644 --- /dev/null +++ b/yi-mode-javascript.cabal @@ -0,0 +1,47 @@ +-- This file has been generated from package.yaml by hpack version 0.14.0. +-- +-- see: https://github.com/sol/hpack + +name: yi-mode-javascript +version: 0.13 +synopsis: Yi editor javascript mode +category: Yi +homepage: https://github.com/yi-editor/yi#readme +bug-reports: https://github.com/yi-editor/yi/issues +maintainer: Yi developers +license: GPL-2 +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/yi-editor/yi + +library + hs-source-dirs: + src + ghc-options: -Wall -ferror-spans + include-dirs: + src/Yi/Lexer + build-depends: + base >= 4.8 && < 5 + , array + , binary >= 0.7 + , data-default + , dlist + , filepath + , microlens-platform + , mtl + , text + , yi-core + , yi-language + , yi-rope + exposed-modules: + Yi.Config.Default.JavaScriptMode + Yi.Mode.JavaScript + Yi.Syntax.JavaScript + Yi.Verifier.JavaScript + Yi.Lexer.JavaScript + other-modules: + Paths_yi_mode_javascript + default-language: Haskell2010