diff --git a/elm-format.cabal b/elm-format.cabal index 252a27067..f87a3b6ff 100644 --- a/elm-format.cabal +++ b/elm-format.cabal @@ -76,7 +76,6 @@ library Parse.Type Reporting.Annotation Reporting.Error.Syntax - Reporting.Region Util.List other-modules: @@ -90,6 +89,8 @@ library Cheapskate.Types Cheapskate.Util CommandLine.Helpers + Data.Index + Elm.Name ElmFormat.Execute ElmFormat.Filesystem ElmFormat.FileStore @@ -112,8 +113,15 @@ library Parse.Declaration Parse.Module Parse.Parse - Parse.State + Parse.ParsecAdapter + Parse.Primitives + Parse.Primitives.Internals + Parse.Primitives.Symbol + Parse.Primitives.Variable + Parse.Primitives.Whitespace Parse.Whitespace + Reporting.Doc + Reporting.Render.Code Reporting.Report Reporting.Result ReversedList @@ -128,11 +136,9 @@ library directory >= 1.3.3.0 && < 2, filepath >= 1.4.2.1 && < 2, free >= 5.1.1 && < 6, - indents >= 0.3.3 && < 0.4, json >= 0.9.3 && < 0.10, mtl >= 2.2.2 && < 3, optparse-applicative >= 0.14.3.0 && < 0.15, - parsec >= 3.1.13.0 && < 4, process >= 1.6.5.0 && < 2, split >= 0.2.3.3 && < 0.3, text >= 1.2.3.1 && < 2 @@ -198,7 +204,6 @@ test-Suite elm-format-tests cmark >= 0.5.6.3 && < 0.6, containers >= 0.6.0.1 && < 0.7, mtl >= 2.2.2 && < 3, - parsec >= 3.1.13.0 && < 4, split >= 0.2.3.3 && < 0.3, text >= 1.2.3.1 && < 2, elm-format diff --git a/parser/src/AST/Declaration.hs b/parser/src/AST/Declaration.hs index f1fed0fc4..b15d8338a 100644 --- a/parser/src/AST/Declaration.hs +++ b/parser/src/AST/Declaration.hs @@ -35,7 +35,7 @@ instance A.Strippable Declaration where stripRegion d = case d of Definition a b c e -> - Definition (A.stripRegion a) b c (A.stripRegion $ A.map A.stripRegion e) + Definition (A.stripRegion a) b c (A.stripRegion $ fmap A.stripRegion e) _ -> d -- INFIX STUFF @@ -66,5 +66,5 @@ instance A.Strippable a => A.Strippable (TopLevelStructure a) where stripRegion d = case d of Entry d' -> - Entry $ A.stripRegion $ A.map A.stripRegion d' + Entry $ A.stripRegion $ fmap A.stripRegion d' _ -> d diff --git a/parser/src/AST/Expression.hs b/parser/src/AST/Expression.hs index 6d6816f36..d0db2b4de 100644 --- a/parser/src/AST/Expression.hs +++ b/parser/src/AST/Expression.hs @@ -73,13 +73,13 @@ instance A.Strippable Expr' where case d of App e0 es b -> App - (A.stripRegion $ A.map A.stripRegion e0) - (map (fmap (A.stripRegion . A.map A.stripRegion)) es) + (A.stripRegion $ fmap A.stripRegion e0) + (map (fmap (A.stripRegion . fmap A.stripRegion)) es) b Tuple es b -> Tuple - (map (fmap (A.stripRegion . A.map A.stripRegion)) es) + (map (fmap (A.stripRegion . fmap A.stripRegion)) es) b _ -> d diff --git a/parser/src/AST/Json.hs b/parser/src/AST/Json.hs index ede1d5d27..d9078295c 100644 --- a/parser/src/AST/Json.hs +++ b/parser/src/AST/Json.hs @@ -15,7 +15,6 @@ import Text.JSON hiding (showJSON) import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified ElmFormat.Version -import qualified Reporting.Region as Region pleaseReport :: String -> String -> a @@ -63,19 +62,19 @@ class ToJSON a where showJSON :: a -> JSValue -instance ToJSON Region.Region where - showJSON region = +instance ToJSON Region where + showJSON (Region start end) = makeObj - [ ( "start", showJSON $ Region.start region ) - , ( "end", showJSON $ Region.end region ) + [ ( "start", showJSON start ) + , ( "end", showJSON end ) ] -instance ToJSON Region.Position where - showJSON pos = +instance ToJSON Position where + showJSON (Position line column) = makeObj - [ ( "line", JSRational False $ toRational $ Region.line pos ) - , ( "col", JSRational False $ toRational $ Region.column pos ) + [ ( "line", JSRational False $ toRational line ) + , ( "col", JSRational False $ toRational column ) ] @@ -105,7 +104,7 @@ instance ToJSON DetailedListing where instance ToJSON (TopLevelStructure Declaration) where - showJSON (Entry (A region (Definition (A _ (VarPattern (LowercaseIdentifier var))) _ _ expr))) = + showJSON (Entry (At region (Definition (At _ (VarPattern (LowercaseIdentifier var))) _ _ expr))) = makeObj [ type_ "Definition" , ("name" , JSString $ toJSString var) @@ -116,7 +115,7 @@ instance ToJSON (TopLevelStructure Declaration) where instance ToJSON Expr where - showJSON (A region expr) = + showJSON (At region expr) = case expr of Unit _ -> makeObj [ type_ "UnitLiteral" ] @@ -261,7 +260,7 @@ instance ToJSON Expr where Lambda parameters _ body _ -> makeObj [ type_ "AnonymousFunction" - , ("parameters", JSArray $ map (\(_, A _ pat) -> showJSON pat) parameters) + , ("parameters", JSArray $ map (\(_, At _ pat) -> showJSON pat) parameters) , ("body", showJSON body) ] @@ -298,7 +297,7 @@ instance ToJSON Expr where , ( "subject", showJSON subject ) , ( "branches" , JSArray $ map - (\(Commented _ (A _ pat) _, (_, body)) -> + (\(Commented _ (At _ pat) _, (_, body)) -> makeObj [ ("pattern", showJSON pat) , ("body", showJSON body) @@ -312,7 +311,7 @@ instance ToJSON Expr where JSString $ toJSString "TODO: Expr" -variableReference :: Region.Region -> String -> JSValue +variableReference :: Region -> String -> JSValue variableReference region name = makeObj [ type_ "VariableReference" @@ -321,7 +320,7 @@ variableReference region name = ] -sourceLocation :: Region.Region -> (String, JSValue) +sourceLocation :: Region -> (String, JSValue) sourceLocation region = ( "sourceLocation", showJSON region ) @@ -329,7 +328,7 @@ sourceLocation region = instance ToJSON LetDeclaration where showJSON letDeclaration = case letDeclaration of - LetDefinition (A _ (VarPattern (LowercaseIdentifier var))) [] _ expr -> + LetDefinition (At _ (VarPattern (LowercaseIdentifier var))) [] _ expr -> makeObj [ type_ "Definition" , ("name" , JSString $ toJSString var) @@ -355,11 +354,6 @@ type_ t = ("type", JSString $ toJSString t) -nowhere :: Region.Position -nowhere = - Region.Position 0 0 - - noRegion :: a -> Located a noRegion = - at nowhere nowhere + At zero diff --git a/parser/src/Data/Index.hs b/parser/src/Data/Index.hs new file mode 100644 index 000000000..ff4e625bb --- /dev/null +++ b/parser/src/Data/Index.hs @@ -0,0 +1,132 @@ +module Data.Index + ( ZeroBased + , first + , second + , third + , next + , toMachine + , toHuman + , indexedMap + , indexedTraverse + , indexedForA + , VerifiedList(..) + , indexedZipWith + , indexedZipWithA + ) + where + + +import Control.Monad (liftM) +import Data.Binary + + + +-- ZERO BASED + + +newtype ZeroBased = ZeroBased Int + deriving (Eq, Ord) + + +first :: ZeroBased +first = + ZeroBased 0 + + +second :: ZeroBased +second = + ZeroBased 1 + + +third :: ZeroBased +third = + ZeroBased 2 + + +{-# INLINE next #-} +next :: ZeroBased -> ZeroBased +next (ZeroBased i) = + ZeroBased (i + 1) + + + +-- DESTRUCT + + +toMachine :: ZeroBased -> Int +toMachine (ZeroBased index) = + index + + +toHuman :: ZeroBased -> Int +toHuman (ZeroBased index) = + index + 1 + + + +-- INDEXED MAP + + +{-# INLINE indexedMap #-} +indexedMap :: (ZeroBased -> a -> b) -> [a] -> [b] +indexedMap func xs = + zipWith func (map ZeroBased [0 .. length xs]) xs + + +{-# INLINE indexedTraverse #-} +indexedTraverse :: (Applicative f) => (ZeroBased -> a -> f b) -> [a] -> f [b] +indexedTraverse func xs = + sequenceA (indexedMap func xs) + + +{-# INLINE indexedForA #-} +indexedForA :: (Applicative f) => [a] -> (ZeroBased -> a -> f b) -> f [b] +indexedForA xs func = + sequenceA (indexedMap func xs) + + + +-- VERIFIED/INDEXED ZIP + + +data VerifiedList a + = LengthMatch [a] + | LengthMismatch Int Int + + +indexedZipWith :: (ZeroBased -> a -> b -> c) -> [a] -> [b] -> VerifiedList c +indexedZipWith func listX listY = + indexedZipWithHelp func 0 listX listY [] + + +indexedZipWithHelp :: (ZeroBased -> a -> b -> c) -> Int -> [a] -> [b] -> [c] -> VerifiedList c +indexedZipWithHelp func index listX listY revListZ = + case (listX, listY) of + ([], []) -> + LengthMatch (reverse revListZ) + + (x:xs, y:ys) -> + indexedZipWithHelp func (index + 1) xs ys $ + func (ZeroBased index) x y : revListZ + + (_, _) -> + LengthMismatch (index + length listX) (index + length listY) + + +indexedZipWithA :: (Applicative f) => (ZeroBased -> a -> b -> f c) -> [a] -> [b] -> f (VerifiedList c) +indexedZipWithA func listX listY = + case indexedZipWith func listX listY of + LengthMatch xs -> + LengthMatch <$> sequenceA xs + + LengthMismatch x y -> + pure (LengthMismatch x y) + + + +-- BINARY + + +instance Binary ZeroBased where + get = liftM ZeroBased get + put (ZeroBased n) = put n diff --git a/parser/src/Elm/Name.hs b/parser/src/Elm/Name.hs new file mode 100644 index 000000000..9604f30e3 --- /dev/null +++ b/parser/src/Elm/Name.hs @@ -0,0 +1,342 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +module Elm.Name + ( Name + -- -- utilities + -- , length + -- , contains + -- , startsWith + -- , drop + -- -- conversions + -- , toText + , toString + -- , toBuilder + -- , toDotlessBuilder + -- , toShort + -- -- helpers + -- , addIndex + -- , addSafeIndex + -- , toCompositeName + -- , sepBy + -- -- create + , fromForeignPtr + -- , fromString + -- , fromLetter + -- , fromText + -- -- interned + -- , int, float, bool, char, string + -- , maybe, result, list, array, dict, tuple, jsArray + -- , task, router, cmd, sub, platform, virtualDom + -- , shader, debug, debugger, bitwise, basics + -- , utils, negate, true, false, value + -- , node, program, main, dollar, identity + -- , replModule + ) + where + + +import Prelude hiding (drop, length, maybe, negate) +import Data.Binary +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Short as S +import qualified Data.Char as Char +import qualified Data.String as String +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr) + + + +-- NAME + + +newtype Name = Name { _name :: Text.Text } + deriving (Eq, Ord) + + +length :: Name -> Int +length (Name name) = + Text.length name + + +contains :: Word8 -> Name -> Bool +contains word (Name name) = + Text.isInfixOf (Text.singleton (Char.chr (fromIntegral word))) name + + +startsWith :: Name -> Name -> Bool +startsWith (Name prefix) (Name name) = + Text.isPrefixOf prefix name + + +drop :: Int -> Name -> Name +drop numBytes (Name name) = + Name (Text.drop numBytes name) + + + +-- CONVERSIONS + + +toText :: Name -> Text.Text +toText (Name name) = + name + + +toString :: Name -> String +toString (Name name) = + Text.unpack name + + +toBuilder :: Name -> B.Builder +toBuilder (Name name) = + Text.encodeUtf8Builder name + + +toDotlessBuilder :: Name -> B.Builder +toDotlessBuilder (Name name) = + Text.encodeUtf8Builder (Text.replace "." "$" name) + + +toShort :: Name -> S.ShortByteString +toShort (Name name) = + S.toShort (Text.encodeUtf8 name) + + +addIndex :: Name -> Int -> Name +addIndex (Name name) index = + Name (Text.append name (Text.pack (show index))) + + +addSafeIndex :: Name -> Int -> Name +addSafeIndex (Name name) index = + Name $ Text.append name $ Text.pack $ + if Char.isDigit (Text.last name) then + '_' : show index + else + show index + + +toCompositeName :: [Name] -> Name +toCompositeName names = + Name (Text.cons '$' (Text.intercalate "$" (map _name names))) + + +sepBy :: Word8 -> Name -> Name -> Name +sepBy sep (Name home) (Name name) = + Name (Text.concat [ home, Text.singleton (Char.chr (fromIntegral sep)), name ]) + + + +-- CREATE NAMES + + +fromForeignPtr :: ForeignPtr Word8 -> Int -> Int -> Name +fromForeignPtr fptr offset len = + Name (Text.decodeUtf8 (B.PS fptr offset len)) + + +fromString :: String -> Name +fromString str = + Name (Text.pack str) + + +{- Takes a letter from 0 to 25 -} +fromLetter :: Int -> Name +fromLetter letter = + Name (Text.singleton (Char.chr (97 + letter))) + + +fromText :: Text.Text -> Name +fromText = + Name + + + +-- INSTANCES + + +instance String.IsString Name where + fromString str = + Name (Text.pack str) + + +instance Binary Name where + put (Name name) = put name + get = Name <$> get + + + +-- COMMON NAMES + + +{-# NOINLINE int #-} +int :: Name +int = "Int" + + +{-# NOINLINE float #-} +float :: Name +float = "Float" + + +{-# NOINLINE bool #-} +bool :: Name +bool = "Bool" + + +{-# NOINLINE char #-} +char :: Name +char = "Char" + + +{-# NOINLINE string #-} +string :: Name +string = "String" + + +{-# NOINLINE maybe #-} +maybe :: Name +maybe = "Maybe" + + +{-# NOINLINE result #-} +result :: Name +result = "Result" + + +{-# NOINLINE list #-} +list :: Name +list = "List" + + +{-# NOINLINE array #-} +array :: Name +array = "Array" + + +{-# NOINLINE dict #-} +dict :: Name +dict = "Dict" + + +{-# NOINLINE tuple #-} +tuple :: Name +tuple = "Tuple" + + +{-# NOINLINE jsArray #-} +jsArray :: Name +jsArray = "JsArray" + + +{-# NOINLINE task #-} +task :: Name +task = "Task" + + +{-# NOINLINE router #-} +router :: Name +router = "Router" + + +{-# NOINLINE cmd #-} +cmd :: Name +cmd = "Cmd" + + +{-# NOINLINE sub #-} +sub :: Name +sub = "Sub" + + +{-# NOINLINE platform #-} +platform :: Name +platform = "Platform" + + +{-# NOINLINE virtualDom #-} +virtualDom :: Name +virtualDom = "VirtualDom" + + +{-# NOINLINE shader #-} +shader :: Name +shader = "Shader" + + +{-# NOINLINE debug #-} +debug :: Name +debug = "Debug" + + +{-# NOINLINE debugger #-} +debugger :: Name +debugger = "Debugger" + + +{-# NOINLINE bitwise #-} +bitwise :: Name +bitwise = "Bitwise" + + +{-# NOINLINE basics #-} +basics :: Name +basics = "Basics" + + +{-# NOINLINE utils #-} +utils :: Name +utils = "Utils" + + +{-# NOINLINE negate #-} +negate :: Name +negate = "negate" + + +{-# NOINLINE true #-} +true :: Name +true = "True" + + +{-# NOINLINE false #-} +false :: Name +false = "False" + + +{-# NOINLINE value #-} +value :: Name +value = "Value" + + +{-# NOINLINE node #-} +node :: Name +node = "Node" + + +{-# NOINLINE program #-} +program :: Name +program = "Program" + + +{-# NOINLINE main #-} +main :: Name +main = "main" + + +{-# NOINLINE dollar #-} +dollar :: Name +dollar = "$" + + +{-# NOINLINE identity #-} +identity :: Name +identity = "identity" + + +{-# NOINLINE replModule #-} +replModule :: Name +replModule = "Elm_Repl" diff --git a/parser/src/Parse/Expression.hs b/parser/src/Parse/Expression.hs index eacd4be99..9dbc23742 100644 --- a/parser/src/Parse/Expression.hs +++ b/parser/src/Parse/Expression.hs @@ -10,7 +10,6 @@ import Parse.Common import qualified Parse.Helpers as Help import qualified Parse.Literal as Literal import qualified Parse.Pattern as Pattern -import qualified Parse.State as State import qualified Parse.Type as Type import Parse.IParser import Parse.Whitespace diff --git a/parser/src/Parse/Helpers.hs b/parser/src/Parse/Helpers.hs index 4bdb4aea1..52a0c816e 100644 --- a/parser/src/Parse/Helpers.hs +++ b/parser/src/Parse/Helpers.hs @@ -5,16 +5,18 @@ import Prelude hiding (until) import Control.Monad (guard) import Data.Map.Strict hiding (foldl) import qualified Data.Maybe as Maybe -import Text.Parsec hiding (newline, spaces, State) -import Text.Parsec.Indent (indented, runIndent) import AST.V0_16 import qualified AST.Expression import qualified AST.Helpers as Help import qualified AST.Variable -import qualified Parse.State as State +import qualified Data.Text as Text +import qualified Data.Char as Char +import Data.Text.Encoding (encodeUtf8) import Parse.Comments import Parse.IParser +import Parse.ParsecAdapter (string, (<|>), (), many, many1, choice, option, optionMaybe, satisfy, char, eof, lookAhead, notFollowedBy, anyWord8, anyChar) +import Parse.Primitives (run, getPosition, try, oneOf) import Parse.Whitespace import qualified Reporting.Annotation as A import qualified Reporting.Error.Syntax as Syntax @@ -41,15 +43,11 @@ expecting = flip () -- SETUP -iParse :: IParser a -> String -> Either ParseError a -iParse = - iParseWithState "" State.init +iParse :: IParser a -> String -> Either Syntax.Error a +iParse parser input = + run parser (encodeUtf8 $ Text.pack input) -iParseWithState :: SourceName -> State.State -> IParser a -> String -> Either ParseError a -iParseWithState sourceName state aParser input = - runIndent sourceName $ runParserT aParser state sourceName input - -- VARIABLES @@ -60,12 +58,12 @@ var = lowVar :: IParser LowercaseIdentifier lowVar = - LowercaseIdentifier <$> makeVar lower "a lower case name" + LowercaseIdentifier <$> makeVar (satisfy Char.isLower) "a lower case name" capVar :: IParser UppercaseIdentifier capVar = - UppercaseIdentifier <$> makeVar upper "an upper case name" + UppercaseIdentifier <$> makeVar (satisfy Char.isUpper) "an upper case name" qualifiedVar :: IParser AST.Variable.Ref @@ -88,14 +86,14 @@ rLabel = lowVar innerVarChar :: IParser Char innerVarChar = - alphaNum <|> char '_' <|> char '\'' "more letters in this name" + (satisfy Char.isAlphaNum) <|> char '_' <|> char '\'' "more letters in this name" makeVar :: IParser Char -> IParser String makeVar firstChar = do variable <- (:) <$> firstChar <*> many innerVarChar if variable `elem` reserveds - then fail (Syntax.keyword variable) + then fail () -- (Syntax.keyword variable) else return variable @@ -120,7 +118,7 @@ symOp = do op <- many1 (satisfy Help.isSymbol) "an infix operator like +" guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ]) case op of - "." -> notFollowedBy lower >> return (SymbolIdentifier op) + "." -> notFollowedBy (satisfy Char.isLower) >> return (SymbolIdentifier op) _ -> return $ SymbolIdentifier op @@ -291,7 +289,7 @@ separated :: IParser sep -> IParser e -> IParser (Either e (R.Region, (e,Maybe S separated sep expr' = let subparser = - do start <- getMyPosition + do start <- getPosition t1 <- expr' arrow <- optionMaybe $ try ((,) <$> restOfLine <*> whitespace <* sep) case arrow of @@ -300,7 +298,7 @@ separated sep expr' = Just (eolT1, preArrow) -> do postArrow <- whitespace t2 <- separated sep expr' - end <- getMyPosition + end <- getPosition case t2 of Right (_, (t2',eolT2), ts, _) -> return $ \multiline -> Right @@ -342,7 +340,7 @@ constrainedSpacePrefix parser = constrainedSpacePrefix' :: IParser a -> (Bool -> IParser b) -> IParser [((Comments, a), Multiline)] constrainedSpacePrefix' parser constraint = many $ trackNewline $ choice - [ comment <$> try (const <$> spacing <*> lookAhead (oneOf "[({")) <*> parser + [ comment <$> try (const <$> spacing <*> lookAhead (oneOf $ fmap char "[({")) <*> parser , try (comment <$> spacing <*> parser) ] where @@ -350,7 +348,7 @@ constrainedSpacePrefix' parser constraint = spacing = do (n, comments) <- whitespace' - _ <- constraint (not n) Syntax.whitespace + _ <- constraint (not n) -- Syntax.whitespace indented return comments @@ -458,9 +456,11 @@ surround'' leftDelim rightDelim inner = -- HELPERS FOR EXPRESSIONS + +-- TODO: inline this getMyPosition :: IParser R.Position getMyPosition = - R.fromSourcePos <$> getPosition + getPosition addLocation :: IParser a -> IParser (A.Located a) @@ -471,15 +471,15 @@ addLocation expr = located :: IParser a -> IParser (R.Position, a, R.Position) located parser = - do start <- getMyPosition + do start <- getPosition value <- parser - end <- getMyPosition + end <- getPosition return (start, value, end) accessible :: IParser AST.Expression.Expr -> IParser AST.Expression.Expr accessible exprParser = - do start <- getMyPosition + do start <- getPosition annotatedRootExpr@(A.A _ _rootExpr) <- exprParser @@ -492,7 +492,7 @@ accessible exprParser = Just _ -> accessible $ do v <- lowVar - end <- getMyPosition + end <- getPosition return . A.at start end $ -- case rootExpr of -- AST.Expression.VarExpr (AST.Variable.VarRef name@(c:_)) @@ -519,14 +519,6 @@ commentedKeyword word parser = -- ODD COMBINATORS -failure :: String -> IParser String -failure msg = do - inp <- getInput - setInput ('x':inp) - _ <- anyToken - fail msg - - until :: IParser a -> IParser b -> IParser b until p end = go diff --git a/parser/src/Parse/IParser.hs b/parser/src/Parse/IParser.hs index 63b9a746b..5e5cd80cc 100644 --- a/parser/src/Parse/IParser.hs +++ b/parser/src/Parse/IParser.hs @@ -1,9 +1,6 @@ module Parse.IParser where -import Control.Monad.State (State) -import qualified Parse.State as State -import Text.Parsec hiding (newline, spaces, State) +import Parse.Primitives (Parser) - -type SourceM = State SourcePos -type IParser a = ParsecT String State.State SourceM a +-- TODO: inline this +type IParser a = Parser a diff --git a/parser/src/Parse/ParsecAdapter.hs b/parser/src/Parse/ParsecAdapter.hs new file mode 100644 index 000000000..5e164ea7d --- /dev/null +++ b/parser/src/Parse/ParsecAdapter.hs @@ -0,0 +1,219 @@ +module Parse.ParsecAdapter + ( string + , (<|>) + , () + , many + , many1 + , choice + , option, optionMaybe + , satisfy + , char, anyChar + , eof + , lookAhead + , notFollowedBy + , anyWord8 + ) + where + +{-| This module implements parts of Parsec's API in terms of the new Elm 0.19 parser primitives +(`Parse.Primitives.Internals`). +Eventually the rest of the elm-format parsers should be rewritten to more closely match the +Elm 0.19 parser, and once that is done, this module can be removed. +-} + +import Data.Word (Word8) +import qualified Data.ByteString as B +-- import qualified Data.ByteString.Char8 as C +-- import Data.Char (ord) +import qualified Data.Char as Char +import qualified Data.Text as T +import Foreign.ForeignPtr (ForeignPtr) +-- import qualified Reporting.Region as R +import qualified Reporting.Error.Syntax as E +import Data.Text.Encoding (encodeUtf8) +import Parse.Primitives (Parser(Parser), State(State), unsafeIndex, noError, oneOf) + + +toWord8 :: String -> [Word8] +toWord8 = B.unpack . encodeUtf8 . T.pack + + +string :: String -> Parser String +string str = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> + case eatWord8s (toWord8 str) fp offset terminal row col of + Err err -> + cerr err + + Ok newOffset newRow newCol -> + cok str (State fp newOffset terminal indent newRow newCol ctx) noError + + +data EatStringResult + = Err E.ParseError + | Ok Int Int Int + + +eatWord8s :: [Word8] -> ForeignPtr Word8 -> Int -> Int -> Int -> Int -> EatStringResult +eatWord8s str fp offset terminal row col = + case str of + [] -> Ok offset row col + 0x0A {- \n -} : _ -> error "eatWord8s doesn't support matching '\\n'" + h : t -> + if offset >= terminal then + Err noError + else if h == unsafeIndex fp offset then + eatWord8s t fp (offset + 1) terminal row (col + 1) + else + Err noError + + +satisfy :: (Char -> Bool) -> Parser Char +satisfy f = + let + (Parser p) = anyWord8 + in + Parser $ \state cok cerr _ eerr -> + p state + (\a newState e -> + let + c = Char.chr $ fromEnum a + in + if f c + then cok c newState e + else eerr noError + ) + (\ e -> cerr e) + (\_ _ _ -> error "satisfy got empty from anyWord8") + (\ e -> eerr e) + + +char :: Char -> Parser Char +char c = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> + case eatWord8s (toWord8 [c]) fp offset terminal row col of + Err err -> + cerr err + + Ok newOffset newRow newCol -> + cok c (State fp newOffset terminal indent newRow newCol ctx) noError + + +anyChar :: Parser Char +anyChar = + fmap (Char.chr . fromEnum) anyWord8 + + +infix 0 +() :: Parser a -> String -> Parser a +a message = + -- TODO: convert uses of to how elm/compiler does things + a + +infixr 1 <|> +(<|>) :: Parser a -> Parser a -> Parser a +a <|> b = + oneOf [ a, b ] + + +many1 :: Parser a -> Parser [a] +many1 (Parser parser) = + Parser $ \initialState cok cerr _ eerr -> + let + parseFirst state _err = + parser state + (\a newState e -> parseNext [a] newState e) + (\ e -> cerr e) + (\_ _ _ -> error "many1 succeeded with empty parser") + (\ e -> eerr e) + + -- help :: [a] -> State -> E.ParseError b + parseNext acc state err = + -- TODO: is the error passing correct? what do errors mean for parser success cases? + parser state + (\a newState e -> parseNext (a:acc) newState e) + (\ e -> cerr e) + (\_ _ _ -> error "many1 succeeded with empty parser") + (\ _ -> cok (reverse acc) state err) + in + parseFirst initialState noError + + +many :: Parser a -> Parser [a] +many (Parser parser) = + Parser $ \initialState cok cerr _ _ -> -- TODO: do we need to use eerr when the first term fails? + let + -- help :: [a] -> State -> E.ParseError b + parseNext acc state err = + -- TODO: is the error passing correct? what do errors mean for parser success cases? + parser state + (\a newState e -> parseNext (a:acc) newState e) + (\ e -> cerr e) + (\_ _ _ -> error "many succeeded with empty parser") + (\ _ -> cok (reverse acc) state err) + in + parseNext [] initialState noError + + +choice :: [Parser a] -> Parser a +choice = + oneOf + + +option :: a -> Parser a -> Parser a +option a parser = + oneOf [parser, pure a] + + +optionMaybe :: Parser a -> Parser (Maybe a) +optionMaybe parser = + option Nothing (fmap Just parser) + + +eof :: Parser () +eof = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr eok eerr -> + if offset >= terminal then + eok noError + else + eerr noError + + +lookAhead :: Parser a -> Parser a +lookAhead (Parser parser) = + Parser $ \state cok cerr eok eer -> + let + cok' a _ e = + cok a state e + in + parser state cok' cerr eok eer + + +notFollowedBy :: Parser a -> Parser () +notFollowedBy (Parser parser) = + Parser $ \state _ _ eok eerr -> + parser state + (\_ _ _ -> eerr noError) + (\_ -> eok () state noError) + (\_ _ _ -> eerr noError) + (\_ -> eok () state noError) + + +anyWord8 :: Parser Word8 +anyWord8 = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr -> + if offset >= terminal then + eerr noError + else + case unsafeIndex fp offset of + 0x0A {- \n -} -> + cok 0x0A (State fp (offset + 1) terminal indent (row + 1) 1 ctx) noError + + 0x0D {- \r -} -> + cok 0x0D (State fp (offset + 1) terminal indent row col ctx) noError + + 0x09 {- \t -} -> + cerr (E.ParseError row col E.Tab) + + word -> + cok word (State fp (offset + 1) terminal indent row (col + 1) ctx) noError diff --git a/parser/src/Parse/Primitives.hs b/parser/src/Parse/Primitives.hs new file mode 100644 index 000000000..57eef90f2 --- /dev/null +++ b/parser/src/Parse/Primitives.hs @@ -0,0 +1,408 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples #-} +module Parse.Primitives + ( fromByteString + , Parser(..) + , State(..) + , Row + , Col + , oneOf, oneOfWithFallback + , inContext, specialize + , getPosition, getCol, addLocation, addEnd + , getIndent, setIndent, withIndent, withBacksetIndent + , word1, word2 + , unsafeIndex, isWord, getCharWidth + , Snippet(..) + , fromSnippet + ) + where + + +import Prelude hiding (length) +import qualified Control.Applicative as Applicative (Applicative(..)) +import qualified Data.ByteString.Internal as B +import Data.Word (Word8, Word16) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peek) +import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) + +import qualified Reporting.Annotation as A + + + +-- PARSER + + +newtype Parser x a = + Parser ( + forall b. + State + -> (a -> State -> b) -- consumed ok + -> (a -> State -> b) -- empty ok + -> (Row -> Col -> (Row -> Col -> x) -> b) -- consumed err + -> (Row -> Col -> (Row -> Col -> x) -> b) -- empty err + -> b + ) + + +data State = -- TODO try taking some out to avoid allocation? + State + { _src :: ForeignPtr Word8 + , _pos :: !(Ptr Word8) + , _end :: !(Ptr Word8) + , _indent :: !Word16 + , _row :: !Row + , _col :: !Col + } + + +type Row = Word16 +type Col = Word16 + + + +-- FUNCTOR + + +instance Functor (Parser x) where + {-# INLINE fmap #-} + fmap f (Parser parser) = + Parser $ \state cok eok cerr eerr -> + let + cok' a s = cok (f a) s + eok' a s = eok (f a) s + in + parser state cok' eok' cerr eerr + + + +-- APPLICATIVE + + +instance Applicative.Applicative (Parser x) where + {-# INLINE pure #-} + pure = return + + {-# INLINE (<*>) #-} + (<*>) (Parser parserFunc) (Parser parserArg) = + Parser $ \state cok eok cerr eerr -> + let + cokF func s1 = + let + cokA arg s2 = cok (func arg) s2 + in + parserArg s1 cokA cokA cerr cerr + + eokF func s1 = + let + cokA arg s2 = cok (func arg) s2 + eokA arg s2 = eok (func arg) s2 + in + parserArg s1 cokA eokA cerr eerr + in + parserFunc state cokF eokF cerr eerr + + + + + + +-- ONE OF + + +{-# INLINE oneOf #-} +oneOf :: (Row -> Col -> x) -> [Parser x a] -> Parser x a +oneOf toError parsers = + Parser $ \state cok eok cerr eerr -> + oneOfHelp state cok eok cerr eerr toError parsers + + +oneOfHelp + :: State + -> (a -> State -> b) + -> (a -> State -> b) + -> (Row -> Col -> (Row -> Col -> x) -> b) + -> (Row -> Col -> (Row -> Col -> x) -> b) + -> (Row -> Col -> x) + -> [Parser x a] + -> b +oneOfHelp state cok eok cerr eerr toError parsers = + case parsers of + Parser parser : parsers -> + let + eerr' _ _ _ = + oneOfHelp state cok eok cerr eerr toError parsers + in + parser state cok eok cerr eerr' + + [] -> + let + (State _ _ _ _ row col) = state + in + eerr row col toError + + + +-- ONE OF WITH FALLBACK + + +{-# INLINE oneOfWithFallback #-} +oneOfWithFallback :: [Parser x a] -> a -> Parser x a -- TODO is this function okay? Worried about allocation/laziness with fallback values. +oneOfWithFallback parsers fallback = + Parser $ \state cok eok cerr _ -> + oowfHelp state cok eok cerr parsers fallback + + +oowfHelp + :: State + -> (a -> State -> b) + -> (a -> State -> b) + -> (Row -> Col -> (Row -> Col -> x) -> b) + -> [Parser x a] + -> a + -> b +oowfHelp state cok eok cerr parsers fallback = + case parsers of + [] -> + eok fallback state + + Parser parser : parsers -> + let + eerr' _ _ _ = + oowfHelp state cok eok cerr parsers fallback + in + parser state cok eok cerr eerr' + + + +-- MONAD + + +instance Monad (Parser x) where + {-# INLINE return #-} + return value = + Parser $ \state _ eok _ _ -> + eok value state + + {-# INLINE (>>=) #-} + (Parser parserA) >>= callback = + Parser $ \state cok eok cerr eerr -> + let + cok' a s = + case callback a of + Parser parserB -> parserB s cok cok cerr cerr + + eok' a s = + case callback a of + Parser parserB -> parserB s cok eok cerr eerr + in + parserA state cok' eok' cerr eerr + + + +-- FROM BYTESTRING + + +fromByteString :: Parser x a -> (Row -> Col -> x) -> B.ByteString -> Either x a +fromByteString (Parser parser) toBadEnd (B.PS fptr offset length) = + B.accursedUnutterablePerformIO $ + let + toOk' = toOk toBadEnd + !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset + !end = plusPtr pos length + !result = parser (State fptr pos end 0 1 1) toOk' toOk' toErr toErr + in + do touchForeignPtr fptr + return result + + +toOk :: (Row -> Col -> x) -> a -> State -> Either x a +toOk toBadEnd !a (State _ pos end _ row col) = + if pos == end + then Right a + else Left (toBadEnd row col) + + +toErr :: Row -> Col -> (Row -> Col -> x) -> Either x a +toErr row col toError = + Left (toError row col) + + + +-- FROM SNIPPET + + +data Snippet = + Snippet + { _fptr :: ForeignPtr Word8 + , _offset :: Int + , _length :: Int + , _offRow :: Row + , _offCol :: Col + } + + +fromSnippet :: Parser x a -> (Row -> Col -> x) -> Snippet -> Either x a +fromSnippet (Parser parser) toBadEnd (Snippet fptr offset length row col) = + B.accursedUnutterablePerformIO $ + let + toOk' = toOk toBadEnd + !pos = plusPtr (unsafeForeignPtrToPtr fptr) offset + !end = plusPtr pos length + !result = parser (State fptr pos end 0 row col) toOk' toOk' toErr toErr + in + do touchForeignPtr fptr + return result + + + +-- POSITION + + +getCol :: Parser x Word16 +getCol = + Parser $ \state@(State _ _ _ _ _ col) _ eok _ _ -> + eok col state + + +{-# INLINE getPosition #-} +getPosition :: Parser x A.Position +getPosition = + Parser $ \state@(State _ _ _ _ row col) _ eok _ _ -> + eok (A.Position row col) state + + +addLocation :: Parser x a -> Parser x (A.Located a) +addLocation (Parser parser) = + Parser $ \state@(State _ _ _ _ sr sc) cok eok cerr eerr -> + let + cok' a s@(State _ _ _ _ er ec) = cok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s + eok' a s@(State _ _ _ _ er ec) = eok (A.At (A.Region (A.Position sr sc) (A.Position er ec)) a) s + in + parser state cok' eok' cerr eerr + + +addEnd :: A.Position -> a -> Parser x (A.Located a) +addEnd start value = + Parser $ \state@(State _ _ _ _ row col) _ eok _ _ -> + eok (A.at start (A.Position row col) value) state + + + +-- INDENT + + +getIndent :: Parser x Word16 +getIndent = + Parser $ \state@(State _ _ _ indent _ _) _ eok _ _ -> + eok indent state + + +setIndent :: Word16 -> Parser x () +setIndent indent = + Parser $ \(State src pos end _ row col) _ eok _ _ -> + let + !newState = State src pos end indent row col + in + eok () newState + + +withIndent :: Parser x a -> Parser x a +withIndent (Parser parser) = + Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr -> + let + cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c) + eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c) + in + parser (State src pos end col row col) cok' eok' cerr eerr + + +withBacksetIndent :: Word16 -> Parser x a -> Parser x a +withBacksetIndent backset (Parser parser) = + Parser $ \(State src pos end oldIndent row col) cok eok cerr eerr -> + let + cok' a (State s p e _ r c) = cok a (State s p e oldIndent r c) + eok' a (State s p e _ r c) = eok a (State s p e oldIndent r c) + in + parser (State src pos end (col - backset) row col) cok' eok' cerr eerr + + + +-- CONTEXT + + +inContext :: (x -> Row -> Col -> y) -> Parser y start -> Parser x a -> Parser y a +inContext addContext (Parser parserStart) (Parser parserA) = + Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr -> + let + cerrA r c tx = cerr row col (addContext (tx r c)) + eerrA r c tx = eerr row col (addContext (tx r c)) + + cokS _ s = parserA s cok cok cerrA cerrA + eokS _ s = parserA s cok eok cerrA eerrA + in + parserStart state cokS eokS cerr eerr + + +specialize :: (x -> Row -> Col -> y) -> Parser x a -> Parser y a +specialize addContext (Parser parser) = + Parser $ \state@(State _ _ _ _ row col) cok eok cerr eerr -> + let + cerr' r c tx = cerr row col (addContext (tx r c)) + eerr' r c tx = eerr row col (addContext (tx r c)) + in + parser state cok eok cerr' eerr' + + + +-- SYMBOLS + + +word1 :: Word8 -> (Row -> Col -> x) -> Parser x () +word1 word toError = + Parser $ \(State src pos end indent row col) cok _ _ eerr -> + if pos < end && unsafeIndex pos == word then + let !newState = State src (plusPtr pos 1) end indent row (col + 1) in + cok () newState + else + eerr row col toError + + +word2 :: Word8 -> Word8 -> (Row -> Col -> x) -> Parser x () +word2 w1 w2 toError = + Parser $ \(State src pos end indent row col) cok _ _ eerr -> + let + !pos1 = plusPtr pos 1 + in + if pos1 < end && unsafeIndex pos == w1 && unsafeIndex pos1 == w2 then + let !newState = State src (plusPtr pos 2) end indent row (col + 2) in + cok () newState + else + eerr row col toError + + + +-- LOW-LEVEL CHECKS + + +unsafeIndex :: Ptr Word8 -> Word8 +unsafeIndex ptr = + B.accursedUnutterablePerformIO (peek ptr) + + +{-# INLINE isWord #-} +isWord :: Ptr Word8 -> Ptr Word8 -> Word8 -> Bool +isWord pos end word = + pos < end && unsafeIndex pos == word + + +getCharWidth :: Word8 -> Int +getCharWidth word + | word < 0x80 = 1 + | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits." + | word < 0xe0 = 2 + | word < 0xf0 = 3 + | word < 0xf8 = 4 + | True = error "Need UTF-8 encoded input. Ran into unrecognized bits." + diff --git a/parser/src/Parse/Primitives/Internals.hs b/parser/src/Parse/Primitives/Internals.hs new file mode 100644 index 000000000..c93722a96 --- /dev/null +++ b/parser/src/Parse/Primitives/Internals.hs @@ -0,0 +1,243 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# LANGUAGE BangPatterns, Rank2Types, UnboxedTuples, OverloadedStrings #-} +module Parse.Primitives.Internals + ( Parser(..) + , State(..) + , noError, expect + , unsafeIndex, isWord, getCharWidth + , isSubstring, isNonNewlineAscii + , oneOf + ) + where + + +import Prelude hiding (length) +import qualified Control.Applicative as Applicative (Applicative(..)) +import Control.Monad +import qualified Data.ByteString.Internal as B +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (peekByteOff) +import GHC.ForeignPtr (touchForeignPtr, unsafeForeignPtrToPtr) +import GHC.Word (Word8) + +import qualified Reporting.Error.Syntax as E + + + +-- PARSER + + +newtype Parser a = + Parser ( + forall b. + State + -> (a -> State -> E.ParseError -> b) -- consumed ok + -> ( E.ParseError -> b) -- consumed err + -> (a -> State -> E.ParseError -> b) -- empty ok + -> ( E.ParseError -> b) -- empty err + -> b + ) + + +data State = + State + { _source :: !(ForeignPtr Word8) + , _offset :: !Int + , _terminal :: !Int + , _indent :: !Int + , _row :: !Int + , _col :: !Int + , _context :: E.ContextStack + } + + + +-- ERRORS + + +{-# NOINLINE noError #-} +noError :: E.ParseError +noError = + E.ParseError 0 0 (E.Theories [] []) + + +{-# INLINE expect #-} +expect :: Int -> Int -> E.ContextStack -> E.Theory -> E.ParseError +expect row col ctx theory = + E.ParseError row col (E.Theories ctx [theory]) + + + +-- LOW-LEVEL CHECKS + + +unsafeIndex :: ForeignPtr Word8 -> Int -> Word8 +unsafeIndex fp offset = + B.accursedUnutterablePerformIO $ + do word <- peekByteOff (unsafeForeignPtrToPtr fp) offset + touchForeignPtr fp + return word + + +{-# INLINE isWord #-} +isWord :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Bool +isWord fp offset terminal word = + offset < terminal && unsafeIndex fp offset == word + + +getCharWidth :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int +getCharWidth _fp _offset _terminal word + | word < 0x80 = 1 + | word < 0xc0 = error "Need UTF-8 encoded input. Ran into unrecognized bits." + | word < 0xe0 = 2 + | word < 0xf0 = 3 + | word < 0xf8 = 4 + | True = error "Need UTF-8 encoded input. Ran into unrecognized bits." + + +{-# INLINE isSubstring #-} +isSubstring :: ForeignPtr Word8 -> Int -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool +isSubstring subFp subOffset subLength fp offset terminal = + offset + subLength <= terminal + && + equals fp offset subFp subOffset subLength + + +equals :: ForeignPtr Word8 -> Int -> ForeignPtr Word8 -> Int -> Int -> Bool +equals fp1 offset1 fp2 offset2 length = + B.accursedUnutterablePerformIO $ + withForeignPtr fp1 $ \ptr1 -> + withForeignPtr fp2 $ \ptr2 -> + do i <- B.memcmp (plusPtr ptr1 offset1) (plusPtr ptr2 offset2) (fromIntegral length) + return $! i == 0 + + + +-- VERIFY BYTESTRING STRUCTURE + + +-- Written weird to try to make TCE more likely +isNonNewlineAscii :: ForeignPtr Word8 -> Int -> Int -> Bool +isNonNewlineAscii !fp !offset !terminal = + if offset < terminal then + let !word = unsafeIndex fp offset in + if word < 128 && word /= 0x0A {- \n -} then + isNonNewlineAscii fp (offset + 1) terminal + else + False + + else + True + + + +-- FUNCTOR + + +instance Functor Parser where + {-# INLINE fmap #-} + fmap f (Parser parser) = + Parser $ \state cok cerr eok eerr -> + let + cok' x s e = cok (f x) s e + eok' x s e = eok (f x) s e + in + parser state cok' cerr eok' eerr + + + +-- APPLICATIVE + + +instance Applicative.Applicative Parser where + {-# INLINE pure #-} + pure = return + + {-# INLINE (<*>) #-} + (<*>) = ap + + +oneOf :: [Parser a] -> Parser a +oneOf parsers = + foldr oneOfHelp allTheOptionsFailed parsers + + +allTheOptionsFailed :: Parser a +allTheOptionsFailed = + Parser $ \_ _ _ _ eerr -> + eerr noError + + +oneOfHelp :: Parser a -> Parser a -> Parser a +oneOfHelp (Parser parser1) (Parser parser2) = + Parser $ \state cok cerr eok eerr -> + let + eerr1 e1 = + let + eok2 y s e2 = eok y s (mergeErrors e1 e2) + eerr2 e2 = eerr (mergeErrors e1 e2) + in + parser2 state cok cerr eok2 eerr2 + in + parser1 state cok cerr eok eerr1 + + +mergeErrors :: E.ParseError -> E.ParseError -> E.ParseError +mergeErrors e1@(E.ParseError r1 c1 p1) e2@(E.ParseError r2 c2 p2) = + case compare r1 r2 of + LT -> e2 + GT -> e1 + EQ -> + case compare c1 c2 of + LT -> e2 + GT -> e1 + EQ -> + case (p1, p2) of + (E.Theories _ [], E.Theories _ _) -> + e2 + + (E.Theories _ _, E.Theories _ []) -> + e1 + + (E.Theories ctx ts1, E.Theories _ ts2) -> + E.ParseError r1 c1 (E.Theories ctx (ts1 ++ ts2)) + + (E.Theories _ _, _) -> + e2 + + (_, _) -> + e1 + + + +-- MONAD + + +instance Monad Parser where + {-# INLINE return #-} + return value = + Parser $ \state _ _ eok _ -> + eok value state noError + + {-# INLINE (>>=) #-} + (Parser parser) >>= callback = + Parser $ \state cok cerr eok eerr -> + let + cok1 x s1 e1 = + let + eok2 y s2 e2 = cok y s2 (mergeErrors e1 e2) + eerr2 e2 = cerr (mergeErrors e1 e2) + in + case callback x of + Parser parser2 -> parser2 s1 cok cerr eok2 eerr2 + + eok1 x s1 e1 = + let + eok2 y s2 e2 = eok y s2 (mergeErrors e1 e2) + eerr2 e2 = eerr (mergeErrors e1 e2) + in + case callback x of + Parser parser2 -> parser2 s1 cok cerr eok2 eerr2 + in + parser state cok1 cerr eok1 eerr diff --git a/parser/src/Parse/Primitives/Kernel.hs b/parser/src/Parse/Primitives/Kernel.hs new file mode 100644 index 000000000..bafe9e34b --- /dev/null +++ b/parser/src/Parse/Primitives/Kernel.hs @@ -0,0 +1,115 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} +module Parse.Primitives.Kernel + ( Special(..) + , chunk + ) + where + + +import Prelude hiding (length) +import qualified Data.ByteString.Internal as B +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr) + +import qualified Elm.Name as N +import Parse.Primitives.Internals (Parser(..), State(..), noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Variable as Var + + + +-- SPECIAL + + +data Special + = Enum Word8 N.Name + | Prod + | Debug + | Import N.Name + | JsField N.Name + | ElmField N.Name + + +-- CHUNK + + +chunk :: Parser (B.ByteString, Maybe Special) +chunk = + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ -> + let + (# maybeSpecial, jsOffset, newOffset, newRow, newCol #) = + chompChunk fp offset terminal row col + + !javascript = B.PS fp offset (jsOffset - offset) + !newState = State fp newOffset terminal indent newRow newCol ctx + in + cok (javascript, maybeSpecial) newState noError + + + +-- CHOMP CHUNK + + +chompChunk :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #) +chompChunk fp offset terminal row col = + if offset >= terminal then + (# Nothing, offset, offset, row, col #) + + else + let !word = I.unsafeIndex fp offset in + if word == 0x5F {- _ -} then + + let + !offset1 = offset + 1 + !offset3 = offset + 3 + in + if offset3 <= terminal && I.unsafeIndex fp offset1 == 0x5F {- _ -} then + chompSpecial fp offset3 terminal row (col + 3) offset + else + chompChunk fp offset1 terminal row (col + 1) + + else if word == 0x0A {- \n -} then + chompChunk fp (offset + 1) terminal (row + 1) 1 + + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + chompChunk fp newOffset terminal row (col + 1) + + + +-- CHOMP TAG + + +-- relies on external checks in chompChunk +chompSpecial :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> (# Maybe Special, Int, Int, Int, Int #) +chompSpecial fp offset terminal row col jsOffset = + let + (# newOffset, newCol #) = + Var.chompInnerChars fp offset terminal col + + !tagOffset = offset - 1 + !word = I.unsafeIndex fp tagOffset + + !special = + if word == 0x24 {- $ -} then + ElmField (N.fromForeignPtr fp offset (newOffset - offset)) + + else + let !name = N.fromForeignPtr fp tagOffset (newOffset - tagOffset) in + if 0x30 <= word && word <= 0x39 then + Enum (fromIntegral (word - 0x30)) name + + else if 0x61 {- a -} <= word && word <= 0x7A {- z -} then + JsField name + + else if name == "DEBUG" then + Debug + + else if name == "PROD" then + Prod + + else + Import name + in + (# Just special, jsOffset, newOffset, row, newCol #) diff --git a/parser/src/Parse/Primitives/Keyword.hs b/parser/src/Parse/Primitives/Keyword.hs new file mode 100644 index 000000000..ea3cbc1eb --- /dev/null +++ b/parser/src/Parse/Primitives/Keyword.hs @@ -0,0 +1,235 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns, OverloadedStrings #-} +module Parse.Primitives.Keyword + ( type_, alias_, port_ + , if_, then_, else_ + , case_, of_ + , let_, in_ + , infix_, left_, right_, non_ + , module_, import_, exposing_, as_, where_, effect_ + , command_, subscription_ + , jsonTrue, jsonFalse, jsonNull + ) + where + + +import Control.Exception (assert) +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Char8 as Char8 + +import Parse.Primitives.Internals (Parser(..), State(..), expect, noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Variable as Var +import qualified Reporting.Error.Syntax as E + + + +-- PRIVATE IMPLEMENTATION + + +{- We can some avoid allocation by declaring all available keywords here. +That means the `keyword` function should only be used within this file on +values tagged as NOINLINE. +-} +keyword :: B.ByteString -> Parser () +keyword kwd@(B.PS kwdFp kwdOffset kwdLength) = + let + !theory = + assert + (I.isNonNewlineAscii kwdFp kwdOffset (kwdOffset + kwdLength)) + (E.Keyword (Char8.unpack kwd)) + in + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> + if I.isSubstring kwdFp kwdOffset kwdLength fp offset terminal + && Var.getInnerWidth fp (offset + kwdLength) terminal == 0 + then + let + !newState = + State fp (offset + kwdLength) terminal indent row (col + kwdLength) ctx + in + cok () newState noError + + else + eerr (expect row col ctx theory) + + + +-- DECLARATIONS + + +{-# NOINLINE type_ #-} +type_ :: Parser () +type_ = + keyword "type" + + +{-# NOINLINE alias_ #-} +alias_ :: Parser () +alias_ = + keyword "alias" + + +{-# NOINLINE port_ #-} +port_ :: Parser () +port_ = + keyword "port" + + + +-- IF EXPRESSIONS + + +{-# NOINLINE if_ #-} +if_ :: Parser () +if_ = + keyword "if" + + +{-# NOINLINE then_ #-} +then_ :: Parser () +then_ = + keyword "then" + + +{-# NOINLINE else_ #-} +else_ :: Parser () +else_ = + keyword "else" + + + +-- CASE EXPRESSIONS + + +{-# NOINLINE case_ #-} +case_ :: Parser () +case_ = + keyword "case" + + +{-# NOINLINE of_ #-} +of_ :: Parser () +of_ = + keyword "of" + + + +-- LET EXPRESSIONS + + +{-# NOINLINE let_ #-} +let_ :: Parser () +let_ = + keyword "let" + + +{-# NOINLINE in_ #-} +in_ :: Parser () +in_ = + keyword "in" + + + +-- INFIXES + + +{-# NOINLINE infix_ #-} +infix_ :: Parser () +infix_ = + keyword "infix" + + +{-# NOINLINE left_ #-} +left_ :: Parser () +left_ = + keyword "left" + + +{-# NOINLINE right_ #-} +right_ :: Parser () +right_ = + keyword "right" + + +{-# NOINLINE non_ #-} +non_ :: Parser () +non_ = + keyword "non" + + + +-- IMPORTS + + +{-# NOINLINE module_ #-} +module_ :: Parser () +module_ = + keyword "module" + + +{-# NOINLINE import_ #-} +import_ :: Parser () +import_ = + keyword "import" + + +{-# NOINLINE exposing_ #-} +exposing_ :: Parser () +exposing_ = + keyword "exposing" + + +{-# NOINLINE as_ #-} +as_ :: Parser () +as_ = + keyword "as" + + +{-# NOINLINE where_ #-} +where_ :: Parser () +where_ = + keyword "where" + + +{-# NOINLINE effect_ #-} +effect_ :: Parser () +effect_ = + keyword "effect" + + + +-- EFFECTS + + +{-# NOINLINE command_ #-} +command_ :: Parser () +command_ = + keyword "command" + + +{-# NOINLINE subscription_ #-} +subscription_ :: Parser () +subscription_ = + keyword "subscription" + + + +-- JSON + + +{-# NOINLINE jsonTrue #-} +jsonTrue :: Parser () +jsonTrue = + keyword "true" + + +{-# NOINLINE jsonFalse #-} +jsonFalse :: Parser () +jsonFalse = + keyword "false" + + +{-# NOINLINE jsonNull #-} +jsonNull :: Parser () +jsonNull = + keyword "null" diff --git a/parser/src/Parse/Primitives/Number.hs b/parser/src/Parse/Primitives/Number.hs new file mode 100644 index 000000000..c7303c0a7 --- /dev/null +++ b/parser/src/Parse/Primitives/Number.hs @@ -0,0 +1,297 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns, UnboxedTuples #-} +module Parse.Primitives.Number + ( Number(..) + , number + , Outcome(..) + , chompInt + , chompHex + , precedence + ) + where + + +import Prelude hiding (length) +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Internal as B +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Word (Word8) + +import qualified AST.Utils.Binop as Binop +import Parse.Primitives.Internals (Parser(..), State(..), noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Variable as Var +import qualified Reporting.Error.Syntax as E + + + +-- HELPERS + + +isDirtyEnd :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Bool +isDirtyEnd fp offset terminal word = + Var.getInnerWidthHelp fp offset terminal word > 0 + + +{-# INLINE isDecimalDigit #-} +isDecimalDigit :: Word8 -> Bool +isDecimalDigit word = + word <= 0x39 {- 9 -} && word >= 0x30 {- 0 -} + + + +-- NUMBERS + + +data Number + = Int Int + | Float Double + + +number :: Parser Number +number = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr -> + if offset >= terminal then + eerr noError + + else + let !word = I.unsafeIndex fp offset in + if not (isDecimalDigit word) then + eerr noError + + else + let + outcome = + if word == 0x30 {- 0 -} then + chompZero fp (offset + 1) terminal + else + chompInt fp (offset + 1) terminal (fromIntegral (word - 0x30 {- 0 -})) + in + case outcome of + Err newOffset problem -> + cerr (E.ParseError row (col + (newOffset - offset)) problem) + + OkInt newOffset n -> + let + !integer = Int n + !newState = State fp newOffset terminal indent row (col + (newOffset - offset)) ctx + in + cok integer newState noError + + OkFloat newOffset -> + let + !length = newOffset - offset + !float = Float $ read $ Char8.unpack $ B.PS fp offset length + !newState = State fp newOffset terminal indent row (col + length) ctx + in + cok float newState noError + + + +-- CHOMP OUTCOME + + +data Outcome + = Err { _offset :: Int, _problem :: E.Problem } + | OkInt { _offset :: Int, _value :: Int } + | OkFloat { _offset :: Int } + + + +-- CHOMP INT + + +chompInt :: ForeignPtr Word8 -> Int -> Int -> Int -> Outcome +chompInt fp !offset terminal !n = + if offset >= terminal then + + OkInt offset n + + else + + let + !word = I.unsafeIndex fp offset + in + if isDecimalDigit word then + chompInt fp (offset + 1) terminal (10 * n + fromIntegral (word - 0x30 {- 0 -})) + + else if word == 0x2E {- . -} then + chompFraction fp (offset + 1) terminal n + + else if word == 0x65 {- e -} || word == 0x45 {- E -} then + chompExponent fp (offset + 1) terminal + + else if isDirtyEnd fp offset terminal word then + Err offset E.BadNumberEnd + + else + OkInt offset n + + + +-- CHOMP FRACTION + + +chompFraction :: ForeignPtr Word8 -> Int -> Int -> Int -> Outcome +chompFraction fp offset terminal n = + if offset >= terminal then + Err offset (E.BadNumberDot n) + + else if isDecimalDigit (I.unsafeIndex fp offset) then + chompFractionHelp fp (offset + 1) terminal + + else + Err offset (E.BadNumberDot n) + + +chompFractionHelp :: ForeignPtr Word8 -> Int -> Int -> Outcome +chompFractionHelp fp offset terminal = + if offset >= terminal then + OkFloat offset + + else + let !word = I.unsafeIndex fp offset in + if isDecimalDigit word then + chompFractionHelp fp (offset + 1) terminal + + else if word == 0x65 {- e -} || word == 0x45 {- E -} then + chompExponent fp (offset + 1) terminal + + else if isDirtyEnd fp offset terminal word then + Err offset E.BadNumberEnd + + else + OkFloat offset + + + +-- CHOMP EXPONENT + + +chompExponent :: ForeignPtr Word8 -> Int -> Int -> Outcome +chompExponent fp offset terminal = + if offset >= terminal then + Err offset E.BadNumberExp + + else + let !word = I.unsafeIndex fp offset in + if isDecimalDigit word then + chompExponentHelp fp (offset + 1) terminal + + else if word == 0x2B {- + -} || word == 0x2D {- - -} then + + let !offset1 = offset + 1 in + if offset1 < terminal && isDecimalDigit (I.unsafeIndex fp offset1) then + chompExponentHelp fp (offset + 2) terminal + else + Err offset E.BadNumberExp + + else + Err offset E.BadNumberExp + + +chompExponentHelp :: ForeignPtr Word8 -> Int -> Int -> Outcome +chompExponentHelp fp offset terminal = + if offset >= terminal then + OkFloat offset + + else if isDecimalDigit (I.unsafeIndex fp offset) then + chompExponentHelp fp (offset + 1) terminal + + else + OkFloat offset + + + +-- CHOMP ZERO + + +chompZero :: ForeignPtr Word8 -> Int -> Int -> Outcome +chompZero fp offset terminal = + if offset >= terminal then + OkInt offset 0 + + else + let !word = I.unsafeIndex fp offset in + if word == 0x78 {- x -} then + chompHexInt fp (offset + 1) terminal + + else if word == 0x2E {- . -} then + chompFraction fp (offset + 1) terminal 0 + + else if isDecimalDigit word then + Err offset E.BadNumberZero + + else if isDirtyEnd fp offset terminal word then + Err offset E.BadNumberEnd + + else + OkInt offset 0 + + +chompHexInt :: ForeignPtr Word8 -> Int -> Int -> Outcome +chompHexInt fp offset terminal = + let (# newOffset, answer #) = chompHex fp offset terminal in + if answer < 0 then + Err newOffset E.BadNumberHex + else + OkInt newOffset answer + + + +-- CHOMP HEX + + +-- Return -1 if it has NO digits +-- Return -2 if it has BAD digits + +{-# INLINE chompHex #-} +chompHex :: ForeignPtr Word8 -> Int -> Int -> (# Int, Int #) +chompHex fp offset terminal = + chompHexHelp fp offset terminal (-1) 0 + + +chompHexHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Int, Int #) +chompHexHelp fp offset terminal answer accumulator = + if offset >= terminal then + (# offset, answer #) + else + let + !newAnswer = + stepHex fp offset terminal (I.unsafeIndex fp offset) accumulator + in + if newAnswer < 0 then + (# offset, if newAnswer == -1 then answer else -2 #) + else + chompHexHelp fp (offset + 1) terminal newAnswer newAnswer + + +{-# INLINE stepHex #-} +stepHex :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int -> Int +stepHex fp offset terminal word acc + | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 16 * acc + fromIntegral (word - 0x30 {- 0 -}) + | 0x61 {- a -} <= word && word <= 0x66 {- f -} = 16 * acc + 10 + fromIntegral (word - 0x61 {- a -}) + | 0x41 {- A -} <= word && word <= 0x46 {- F -} = 16 * acc + 10 + fromIntegral (word - 0x41 {- A -}) + | isDirtyEnd fp offset terminal word = -2 + | True = -1 + + + +-- PRECEDENCE + + +precedence :: Parser Binop.Precedence +precedence = + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> + if offset >= terminal then + eerr noError + + else + let !word = I.unsafeIndex fp offset in + if isDecimalDigit word then + cok + (Binop.Precedence (fromIntegral (word - 0x30 {- 0 -}))) + (State fp (offset + 1) terminal indent row (col + 1) ctx) + noError + else + eerr noError diff --git a/parser/src/Parse/Primitives/Shader.hs b/parser/src/Parse/Primitives/Shader.hs new file mode 100644 index 000000000..ff7a6411d --- /dev/null +++ b/parser/src/Parse/Primitives/Shader.hs @@ -0,0 +1,69 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns #-} +module Parse.Primitives.Shader + ( block + , failure + ) + where + + +import qualified Data.ByteString.Internal as B +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Word (Word8) + +import Parse.Primitives.Internals (Parser(..), State(..), noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Symbol as Symbol +import qualified Reporting.Error.Syntax as E + + + +-- SHADER + + +failure :: Int -> Int -> Text.Text -> Parser a +failure row col msg = + Parser $ \_ _ cerr _ _ -> + cerr (E.ParseError row col (E.BadShader msg)) + + +block :: Parser Text.Text +block = + do Symbol.shaderBlockOpen + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> + case eatShader fp offset terminal row col of + Err -> + cerr (E.ParseError row col E.EndOfFile_Shader) + + Ok newOffset newRow newCol -> + let + !size = newOffset - offset + !shader = Text.decodeUtf8 (B.PS fp offset size) + !newState = State fp (newOffset + 2) terminal indent newRow newCol ctx + in + cok shader newState noError + + +data Result + = Err + | Ok Int Int Int + + +eatShader :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result +eatShader fp offset terminal row col = + if offset >= terminal then + Err + + else + let !word = I.unsafeIndex fp offset in + if word == 0x007C {- | -} && I.isWord fp (offset + 1) terminal 0x5D {- ] -} then + Ok offset row (col + 2) + + else if word == 0x0A {- \n -} then + eatShader fp (offset + 1) terminal (row + 1) 1 + + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + eatShader fp newOffset terminal row (col + 1) diff --git a/parser/src/Parse/Primitives/Symbol.hs b/parser/src/Parse/Primitives/Symbol.hs new file mode 100644 index 000000000..32e6f6d79 --- /dev/null +++ b/parser/src/Parse/Primitives/Symbol.hs @@ -0,0 +1,259 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} +module Parse.Primitives.Symbol + ( underscore + -- , binop + , equals, rightArrow, hasType, comma, pipe, cons, dot, doubleDot, minus, lambda + , leftParen, rightParen, leftSquare, rightSquare, leftCurly, rightCurly + , elmDocCommentOpen, jsMultiCommentOpen, jsMultiCommentClose + , shaderBlockOpen + ) + where + +import Prelude hiding (length) +import Control.Exception (assert) +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Char8 as Char8 +-- import qualified Data.Char as Char +-- import qualified Data.IntSet as IntSet +-- import qualified Data.Vector as Vector +-- import Foreign.ForeignPtr (ForeignPtr) +-- import GHC.Word (Word8) + +-- import qualified Elm.Name as N +import Parse.Primitives.Internals (Parser(..), State(..), expect, noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Variable as Var +import qualified Reporting.Error.Syntax as E +import Reporting.Error.Syntax (Theory(..)) --, BadOp(..)) + + + +-- UNDERSCORE + + +underscore :: Parser () +underscore = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr -> + if offset == terminal || I.unsafeIndex fp offset /= 0x5F {- _ -} then + eerr noError + else + let + !newOffset = offset + 1 + !newCol = col + 1 + in + if Var.getInnerWidth fp newOffset terminal > 0 then + let (# _, badCol #) = Var.chompInnerChars fp newOffset terminal newCol in + cerr (E.ParseError row newCol (E.BadUnderscore badCol)) + else + let !newState = State fp newOffset terminal indent row newCol ctx in + cok () newState noError + + + +-- BINOP + + +-- binop :: Parser N.Name +-- binop = +-- Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr -> +-- let !newOffset = chompOps fp offset terminal in +-- if offset == newOffset then +-- eerr (expect row col ctx E.InfixOp) + +-- else +-- let !length = newOffset - offset in +-- case N.fromForeignPtr fp offset length of +-- "." -> cerr (E.ParseError row col (E.BadOp Dot ctx)) +-- "|" -> cerr (E.ParseError row col (E.BadOp Pipe ctx)) +-- "->" -> cerr (E.ParseError row col (E.BadOp Arrow ctx)) +-- "=" -> cerr (E.ParseError row col (E.BadOp Equals ctx)) +-- ":" -> cerr (E.ParseError row col (E.BadOp HasType ctx)) +-- op -> cok op (State fp newOffset terminal indent row (col + length) ctx) noError + + +-- chompOps :: ForeignPtr Word8 -> Int -> Int -> Int +-- chompOps fp offset terminal = +-- if offset < terminal && isBinopCharHelp (I.unsafeIndex fp offset) then +-- chompOps fp (offset + 1) terminal +-- else +-- offset + + +-- {-# INLINE isBinopCharHelp #-} +-- isBinopCharHelp :: Word8 -> Bool +-- isBinopCharHelp word = +-- word < 128 && Vector.unsafeIndex binopCharVector (fromIntegral word) + + +-- {-# NOINLINE binopCharVector #-} +-- binopCharVector :: Vector.Vector Bool +-- binopCharVector = +-- Vector.generate 128 (\i -> IntSet.member i binopCharSet) + + +-- {-# NOINLINE binopCharSet #-} +-- binopCharSet :: IntSet.IntSet +-- binopCharSet = +-- IntSet.fromList (map Char.ord "+-/*=.<>:&|^?%!") + + + +-- PRIVATE SYMBOL IMPLEMENTATION + + +{- We can some avoid allocation by declaring all available symbols here. +That means the `symbol` function should only be used within this file on +values tagged as NOINLINE. +-} +symbol :: B.ByteString -> Parser () +symbol sym@(B.PS symFp symOffset symLength) = + let + !theory = + assert + (I.isNonNewlineAscii symFp symOffset (symOffset + symLength)) + (Symbol (Char8.unpack sym)) + in + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> + if I.isSubstring symFp symOffset symLength fp offset terminal then + let !newState = State fp (offset + symLength) terminal indent row (col + symLength) ctx in + cok () newState noError + + else + eerr (expect row col ctx theory) + + + +-- COMMON SYMBOLS + + +{-# NOINLINE equals #-} +equals :: Parser () +equals = + symbol "=" + + +{-# NOINLINE rightArrow #-} +rightArrow :: Parser () +rightArrow = + symbol "->" + + +{-# NOINLINE hasType #-} +hasType :: Parser () +hasType = + symbol ":" + + +{-# NOINLINE comma #-} +comma :: Parser () +comma = + symbol "," + + +{-# NOINLINE pipe #-} +pipe :: Parser () +pipe = + symbol "|" + + +{-# NOINLINE cons #-} +cons :: Parser () +cons = + symbol "::" + + +{-# NOINLINE dot #-} +dot :: Parser () +dot = + symbol "." + + +{-# NOINLINE doubleDot #-} +doubleDot :: Parser () +doubleDot = + symbol ".." + + +{-# NOINLINE minus #-} +minus :: Parser () +minus = + symbol "-" + + +{-# NOINLINE lambda #-} +lambda :: Parser () +lambda = + symbol "\\" + + + +-- ENCLOSURES + + +{-# NOINLINE leftParen #-} +leftParen :: Parser () +leftParen = + symbol "(" + + +{-# NOINLINE rightParen #-} +rightParen :: Parser () +rightParen = + symbol ")" + + +{-# NOINLINE leftSquare #-} +leftSquare :: Parser () +leftSquare = + symbol "[" + + +{-# NOINLINE rightSquare #-} +rightSquare :: Parser () +rightSquare = + symbol "]" + + +{-# NOINLINE leftCurly #-} +leftCurly :: Parser () +leftCurly = + symbol "{" + + +{-# NOINLINE rightCurly #-} +rightCurly :: Parser () +rightCurly = + symbol "}" + + + +-- COMMENTS + + +{-# NOINLINE elmDocCommentOpen #-} +elmDocCommentOpen :: Parser () +elmDocCommentOpen = + symbol "{-|" + + +{-# NOINLINE jsMultiCommentOpen #-} +jsMultiCommentOpen :: Parser () +jsMultiCommentOpen = + symbol "/*" + + +{-# NOINLINE jsMultiCommentClose #-} +jsMultiCommentClose :: Parser () +jsMultiCommentClose = + symbol "*/" + + + +-- SHADER + + +{-# NOINLINE shaderBlockOpen #-} +shaderBlockOpen :: Parser () +shaderBlockOpen = + symbol "[glsl|" diff --git a/parser/src/Parse/Primitives/Utf8.hs b/parser/src/Parse/Primitives/Utf8.hs new file mode 100644 index 000000000..b222b9aef --- /dev/null +++ b/parser/src/Parse/Primitives/Utf8.hs @@ -0,0 +1,483 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings, UnboxedTuples #-} +module Parse.Primitives.Utf8 + ( string + , character + ) + where + + +import Prelude hiding (length) +import Data.Bits +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.UTF8 as Utf8 +import qualified Data.Char as Char +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Lazy.Builder as Text +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Word (Word8(..)) + +import Parse.Primitives.Internals (Parser(..), State(..), noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Number as Number +import qualified Reporting.Error.Syntax as E + + + +-- CHARACTER + + +character :: Parser Text.Text +character = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr -> + if offset >= terminal || I.unsafeIndex fp offset /= 0x27 {- ' -} then + eerr noError + + else + case chompChar fp (offset + 1) terminal (col + 1) 0 "" of + Bad newCol problem -> + cerr (E.ParseError row newCol problem) + + Good newOffset newCol numChars mostRecent -> + if numChars /= 1 then + cerr (E.ParseError row col (E.BadChar newCol)) + else + let !newState = State fp newOffset terminal indent row newCol ctx in + cok mostRecent newState noError + + +data CharResult + = Bad Int E.Problem + | Good Int Int Int Text.Text + + +chompChar :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Text.Text -> CharResult +chompChar fp offset terminal col numChars mostRecent = + if offset >= terminal then + Bad col E.EndOfFile_Char + + else + let + !word = I.unsafeIndex fp offset + in + if word == 0x27 {- ' -} then + Good (offset + 1) (col + 1) numChars mostRecent + + else if word == 0x0A {- \n -} then + Bad col E.NewLineInChar + + else if word == 0x22 {- " -} then + chompChar fp (offset + 1) terminal (col + 1) (numChars + 1) "\\\"" + + else if word == 0x5C {- \ -} then + case eatEscape fp (offset + 1) terminal of + EscapeNormal -> + chompChar fp (offset + 2) terminal (col + 2) (numChars + 1) (toText fp offset 2) + + EscapeUnicode delta bits -> + chompChar fp (offset + delta) terminal (col + delta) (numChars + 1) (Text.pack bits) + + EscapeProblem newOffset problem -> + Bad col (E.BadEscape (newOffset - offset) problem) + + EscapeEndOfFile -> + Bad col E.EndOfFile_Char + + else + let !width = I.getCharWidth fp offset terminal word in + chompChar fp (offset + width) terminal (col + 1) (numChars + 1) (toText fp offset width) + + +toText :: ForeignPtr Word8 -> Int -> Int -> Text.Text +toText fp offset length = + Text.decodeUtf8 (B.PS fp offset length) + + + +-- STRINGS + + +string :: Parser Text.Text +string = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ eerr -> + if isDoubleQuote fp offset terminal then + + let + !offset1 = offset + 1 + result = + if isDoubleQuote fp offset1 terminal && isDoubleQuote fp (offset + 2) terminal then + multiString fp (offset + 3) terminal row (col + 3) (offset + 3) mempty + else + singleString fp offset1 terminal row (col + 1) offset1 mempty + in + case result of + Err err -> + cerr err + + Ok newOffset newRow newCol builder -> + let + !newState = State fp newOffset terminal indent newRow newCol ctx + !content = LText.toStrict (Text.toLazyText builder) + in + cok content newState noError + + else + eerr noError + + +{-# INLINE isDoubleQuote #-} +isDoubleQuote :: ForeignPtr Word8 -> Int -> Int -> Bool +isDoubleQuote fp offset terminal = + offset < terminal && I.unsafeIndex fp offset == 0x22 {- " -} + + +data StringResult + = Err E.ParseError + | Ok !Int !Int !Int Text.Builder + + +finalize :: ForeignPtr Word8 -> Int -> Int -> Text.Builder -> Text.Builder +finalize fp start end builder = + if start == end then + builder + else + builder <> Text.fromText (Text.decodeUtf8 (B.PS fp start (end - start))) + + +addBits :: Text.Builder -> ForeignPtr Word8 -> Int -> Int -> Text.Builder -> Text.Builder +addBits bits fp start end builder = + if start == end then + builder <> bits + else + builder <> Text.fromText (Text.decodeUtf8 (B.PS fp start (end - start))) <> bits + + + +-- SINGLE STRINGS + + +singleString :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> Text.Builder -> StringResult +singleString fp offset terminal row col initialOffset builder = + if offset >= terminal then + Err (E.ParseError row col E.EndOfFile_String) + + else + let + !word = I.unsafeIndex fp offset + in + if word == 0x22 {- " -} then + Ok (offset + 1) row (col + 1) $ + finalize fp initialOffset offset builder + + else if word == 0x0A {- \n -} then + Err (E.ParseError row col E.NewLineInString) + + else if word == 0x27 {- ' -} then + let !newOffset = offset + 1 in + singleString fp newOffset terminal row (col + 1) newOffset $ + addBits singleQuoteBits fp initialOffset offset builder + + else if word == 0x5C {- \ -} then + case eatEscape fp (offset + 1) terminal of + EscapeNormal -> + singleString fp (offset + 2) terminal row (col + 2) initialOffset builder + + EscapeUnicode delta bits -> + let !newOffset = offset + delta in + singleString fp newOffset terminal row (col + delta) newOffset $ + addBits (Text.fromText (Text.pack bits)) fp initialOffset offset builder + + EscapeProblem newOffset problem -> + Err (E.ParseError row col (E.BadEscape (newOffset - offset) problem)) + + EscapeEndOfFile -> + Err (E.ParseError row (col + 1) E.EndOfFile_String) + + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + singleString fp newOffset terminal row (col + 1) initialOffset builder + + + +-- MULTI STRINGS + + +multiString :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> Text.Builder -> StringResult +multiString fp offset terminal row col initialOffset builder = + if offset >= terminal then + Err (E.ParseError row col E.EndOfFile_MultiString) + + else + let !word = I.unsafeIndex fp offset in + if word == 0x22 {- " -} && isDoubleQuote fp (offset + 1) terminal && isDoubleQuote fp (offset + 2) terminal then + Ok (offset + 3) row (col + 3) $ + finalize fp initialOffset offset builder + + else if word == 0x27 {- ' -} then + let !offset1 = offset + 1 in + multiString fp offset1 terminal row (col + 1) offset1 $ + addBits singleQuoteBits fp initialOffset offset builder + + else if word == 0x0A {- \n -} then + let !offset1 = offset + 1 in + multiString fp offset1 terminal (row + 1) 1 offset1 $ + addBits newlineBits fp initialOffset offset builder + + else if word == 0x0D {- \r -} then + let !offset1 = offset + 1 in + multiString fp offset1 terminal (row + 1) 1 offset1 $ + addBits carriageReturnBits fp initialOffset offset builder + + else if word == 0x5C {- \ -} then + case eatEscape fp (offset + 1) terminal of + EscapeNormal -> + multiString fp (offset + 2) terminal row (col + 2) initialOffset builder + + EscapeUnicode delta bits -> + let !newOffset = offset + delta in + multiString fp newOffset terminal row (col + delta) newOffset $ + addBits (Text.fromText (Text.pack bits)) fp initialOffset offset builder + + EscapeProblem newOffset problem -> + Err (E.ParseError row col (E.BadEscape (newOffset - offset) problem)) + + EscapeEndOfFile -> + Err (E.ParseError row (col + 1) E.EndOfFile_MultiString) + + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + multiString fp newOffset terminal row (col + 1) initialOffset builder + + + +-- ESCAPE CHARACTERS + + +data Escape + = EscapeNormal + | EscapeUnicode !Int [Char] + | EscapeProblem !Int E.EscapeProblem + | EscapeEndOfFile + + +eatEscape :: ForeignPtr Word8 -> Int -> Int -> Escape +eatEscape fp offset terminal = + if offset >= terminal then + EscapeEndOfFile + + else + case I.unsafeIndex fp offset of + 0x6E {- n -} -> EscapeNormal + 0x72 {- r -} -> EscapeNormal + 0x74 {- t -} -> EscapeNormal + 0x22 {- " -} -> EscapeNormal + 0x27 {- ' -} -> EscapeNormal + 0x5C {- \ -} -> EscapeNormal + 0x75 {- u -} -> eatUnicode fp (offset + 1) terminal + _ -> EscapeProblem offset E.UnknownEscape + + +eatUnicode :: ForeignPtr Word8 -> Int -> Int -> Escape +eatUnicode fp offset terminal = + if offset >= terminal || I.unsafeIndex fp offset /= 0x7B {- { -} then + EscapeProblem offset E.UnicodeSyntax + else + let + !digitOffset = offset + 1 + (# newOffset, code #) = Number.chompHex fp digitOffset terminal + !numDigits = newOffset - digitOffset + in + if newOffset >= terminal || I.unsafeIndex fp newOffset /= 0x7D {- } -} then + EscapeProblem newOffset E.UnicodeSyntax + + else if code < 0 || 0x10FFFF < code then + EscapeProblem (newOffset + 1) E.UnicodeRange + + else if numDigits < 4 || 6 < numDigits then + EscapeProblem (newOffset + 1) $ + E.UnicodeLength numDigits (Utf8.toString (B.PS fp digitOffset numDigits)) + + else + EscapeUnicode (numDigits + 4) (codePointToBits code) + + + +-- CODE POINT TO BITS + + +codePointToBits :: Int -> [Char] +codePointToBits code = + if code < 0xFFFF then + wordToBits code + + else + let + (hi,lo) = divMod (code - 0x10000) 0x400 + in + wordToBits (hi + 0xD800) ++ wordToBits (lo + 0xDC00) + + +wordToBits :: Int -> [Char] +wordToBits code = + [ '\\' -- 0x5C -- \ + , 'u' -- 0x75 -- u + , toBits code 12 + , toBits code 8 + , toBits code 4 + , toBits code 0 + ] + + +toBits :: Int -> Int -> Char +toBits code offset = + let !n = fromIntegral (shiftR code offset .&. 0x000F) in + Char.chr $ if n < 10 then 0x30 + n else 0x61 + (n - 10) + + +{-# NOINLINE singleQuoteBits #-} +singleQuoteBits :: Text.Builder +singleQuoteBits = + "\\\'" + + +{-# NOINLINE newlineBits #-} +newlineBits :: Text.Builder +newlineBits = + "\\n" + + +{-# NOINLINE carriageReturnBits #-} +carriageReturnBits :: Text.Builder +carriageReturnBits = + "\\r" + + + +---- CHUNKS + + +--data Chunk +-- = Copy { _offset :: Int, _length :: Int } +-- | Bits [Word8] + + +--finalize :: Int -> Int -> [Chunk] -> [Chunk] +--finalize start end chunks = +-- reverse $ +-- if start == end then +-- chunks +-- else +-- Copy start (end - start) : chunks + + +--addBits :: [Word8] -> Int -> Int -> [Chunk] -> [Chunk] +--addBits bits start end chunks = +-- if start == end then +-- Bits bits : chunks +-- else +-- Bits bits : Copy start (end - start) : chunks + + +--chunkLength :: Chunk -> Int +--chunkLength chunk = +-- case chunk of +-- Copy _ len -> +-- len + +-- Bits bits -> +-- length bits + + + +---- CHUNK TO SHORT + + +--chunkToShort :: ForeignPtr Word8 -> Chunk -> S.ShortByteString +--chunkToShort fp chunk = +-- unsafeDupablePerformIO $ stToIO $ +-- do MBA mba <- newMutableByteArray (chunkLength chunk) +-- case chunk of +-- Copy offset len -> +-- do copyToByteArray (unsafeForeignPtrToPtr fp `plusPtr` offset) mba 0 len +-- freeze mba + +-- Bits bits -> +-- do _ <- writeBits mba 0 bits +-- freeze mba + + + +---- CHUNKS TO SHORT + + +--chunksToShort :: ForeignPtr Word8 -> [Chunk] -> S.ShortByteString +--chunksToShort fp chunks = +-- unsafeDupablePerformIO $ stToIO $ +-- do MBA mba <- newMutableByteArray (sum (map chunkLength chunks)) +-- chunksToShortHelp fp mba 0 chunks + + +--chunksToShortHelp :: ForeignPtr Word8 -> Prim.MutableByteArray# s -> Int -> [Chunk] -> ST s S.ShortByteString +--chunksToShortHelp fp mba index chunks = +-- case chunks of +-- [] -> +-- freeze mba + +-- chunk : others -> +-- case chunk of +-- Copy offset len -> +-- do copyToByteArray (unsafeForeignPtrToPtr fp `plusPtr` offset) mba index len +-- chunksToShortHelp fp mba (index + len) others + +-- Bits bits -> +-- do newIndex <- writeBits mba index bits +-- chunksToShortHelp fp mba newIndex others + + + +---- CHUNKS HELPERS + + +--data MBA s = MBA (Prim.MutableByteArray# s) + + +--newMutableByteArray :: Int -> ST s (MBA s) +--newMutableByteArray (I# len) = +-- ST $ \s1 -> +-- case Prim.newByteArray# len s1 of +-- (# s2, mba #) -> (# s2, MBA mba #) + + +--freeze :: Prim.MutableByteArray# s -> ST s S.ShortByteString +--freeze mba = +-- ST $ \s1 -> +-- case Prim.unsafeFreezeByteArray# mba s1 of +-- (# s2, ba #) -> (# s2, S.SBS ba #) + + +--copyToByteArray :: Ptr Word8 -> Prim.MutableByteArray# s -> Int -> Int -> ST s () +--copyToByteArray (Ptr src) dst (I# dstOffset) (I# len) = +-- ST $ \s1 -> +-- case Prim.copyAddrToByteArray# src dst dstOffset len s1 of +-- s2 -> (# s2, () #) + + +--writeBits :: Prim.MutableByteArray# s -> Int -> [Word8] -> ST s Int +--writeBits mba index bits = +-- case bits of +-- [] -> +-- return index + +-- word : others -> +-- do writeWord8Array mba index word +-- writeBits mba (index + 1) others + + +--writeWord8Array :: Prim.MutableByteArray# s -> Int -> Word8 -> ST s () +--writeWord8Array mba (I# offset) (W8# word) = +-- ST $ \s1 -> +-- case Prim.writeWord8Array# mba offset word s1 of +-- s2 -> (# s2, () #) diff --git a/parser/src/Parse/Primitives/Variable.hs b/parser/src/Parse/Primitives/Variable.hs new file mode 100644 index 000000000..31e4a78ae --- /dev/null +++ b/parser/src/Parse/Primitives/Variable.hs @@ -0,0 +1,376 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} +module Parse.Primitives.Variable + ( lower + , upper + , moduleName + , Upper(..) + -- , foreignUpper + -- , foreignAlpha + , chompInnerChars + , getInnerWidth + , getInnerWidthHelp + ) + where + + +import Control.Exception (assert) +import Data.Bits ((.&.), (.|.), shiftL) +import qualified Data.Char as Char +import qualified Data.Set as Set +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Word (Word8) + +-- import qualified AST.Source as Src +import qualified Elm.Name as N +import Parse.Primitives.Internals (Parser(..), State(..), expect, noError, unsafeIndex) +import qualified Reporting.Error.Syntax as E + + + +-- LOCAL UPPER + + +upper :: Parser N.Name +upper = + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> + let (# newOffset, newCol #) = chompUpper fp offset terminal col in + if offset == newOffset then + eerr (expect row col ctx E.CapVar) + else + let !name = N.fromForeignPtr fp offset (newOffset - offset) in + cok name (State fp newOffset terminal indent row newCol ctx) noError + + + +-- LOCAL LOWER + + +lower :: Parser N.Name +lower = + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> + let (# newOffset, newCol #) = chompLower fp offset terminal col in + if offset == newOffset then + eerr (expect row col ctx E.LowVar) + else + let !name = N.fromForeignPtr fp offset (newOffset - offset) in + if Set.member name reservedWords then + eerr (expect row col ctx E.LowVar) + else + cok name (State fp newOffset terminal indent row newCol ctx) noError + + +{-# NOINLINE reservedWords #-} +reservedWords :: Set.Set N.Name +reservedWords = + Set.fromList + [ "if", "then", "else" + , "case", "of" + , "let", "in" + , "type" + , "module", "where" + , "import", "exposing" + , "as" + , "port" + ] + + + +-- MODULE NAME + + +moduleName :: Parser N.Name +moduleName = + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> + let (# newOffset, newCol #) = chompUpper fp offset terminal col in + case moduleNameHelp fp newOffset terminal newCol of + Bad badCol -> + eerr (expect row badCol ctx E.CapVar) + + Good end endCol -> + let + !name = N.fromForeignPtr fp offset (end - offset) + !newState = State fp end terminal indent row endCol ctx + in + cok name newState noError + + +data ModuleName = Bad Int | Good Int Int + + +moduleNameHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> ModuleName +moduleNameHelp fp offset terminal col = + if isDot fp offset terminal then + let + !offset1 = offset + 1 + (# newOffset, newCol #) = chompUpper fp offset1 terminal (col + 1) + in + if offset1 == newOffset then + Bad newCol + else + moduleNameHelp fp newOffset terminal newCol + + else + Good offset col + + + +-- FOREIGN UPPER + + +data Upper + = Unqualified N.Name + | Qualified N.Name N.Name + + +-- foreignUpper :: Parser Upper +-- foreignUpper = +-- Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> +-- let (# start, end, newCol #) = foreignUpperHelp fp offset terminal col in +-- if start == end then +-- eerr (expect row newCol ctx E.CapVar) +-- else +-- let +-- !newState = State fp end terminal indent row newCol ctx +-- !name = N.fromForeignPtr fp start (end - start) +-- !foreign = +-- if start == offset then +-- Unqualified name +-- else +-- let !home = N.fromForeignPtr fp offset ((start - 1) - offset) in +-- Qualified home name +-- in +-- cok foreign newState noError + + +-- foreignUpperHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int, Int #) +-- foreignUpperHelp fp offset terminal col = +-- let +-- (# newOffset, newCol #) = chompUpper fp offset terminal col +-- in +-- if offset == newOffset then +-- (# offset, offset, col #) + +-- else if isDot fp newOffset terminal then +-- foreignUpperHelp fp (newOffset + 1) terminal (newCol + 1) + +-- else +-- (# offset, newOffset, newCol #) + + + +-- FOREIGN ALPHA + + +-- foreignAlpha :: Parser Src.Expr_ +-- foreignAlpha = +-- Parser $ \(State fp offset terminal indent row col ctx) cok _ _ eerr -> +-- let (# start, end, newCol, varType #) = foreignAlphaHelp fp offset terminal col in +-- if start == end then +-- eerr (E.ParseError row newCol (E.Theories ctx [E.LowVar, E.CapVar])) +-- else +-- let +-- !newState = State fp end terminal indent row newCol ctx +-- !name = N.fromForeignPtr fp start (end - start) +-- in +-- if start == offset then +-- if Set.member name reservedWords then +-- eerr noError +-- else +-- cok (Src.Var varType name) newState noError +-- else +-- let !home = N.fromForeignPtr fp offset ((start - 1) - offset) in +-- cok (Src.VarQual varType home name) newState noError + + +-- foreignAlphaHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int, Int, Src.VarType #) +-- foreignAlphaHelp fp offset terminal col = +-- let +-- (# lowerOffset, lowerCol #) = chompLower fp offset terminal col +-- in +-- if offset < lowerOffset then +-- (# offset, lowerOffset, lowerCol, Src.Value #) + +-- else +-- let +-- (# upperOffset, upperCol #) = chompUpper fp offset terminal col +-- in +-- if offset == upperOffset then +-- (# offset, offset, col, Src.Ctor #) + +-- else if isDot fp upperOffset terminal then +-- foreignAlphaHelp fp (upperOffset + 1) terminal (upperCol + 1) + +-- else +-- (# offset, upperOffset, upperCol, Src.Ctor #) + + + +---- CHAR CHOMPERS ---- + + + +-- DOTS + + +{-# INLINE isDot #-} +isDot :: ForeignPtr Word8 -> Int -> Int -> Bool +isDot fp offset terminal = + offset < terminal && unsafeIndex fp offset == 0x2e {- . -} + + + +-- UPPER CHARS + + +chompUpper :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #) +chompUpper fp offset terminal col = + let !width = getUpperWidth fp offset terminal in + if width == 0 then + (# offset, col #) + else + chompInnerChars fp (offset + width) terminal (col + 1) + + +{-# INLINE getUpperWidth #-} +getUpperWidth :: ForeignPtr Word8 -> Int -> Int -> Int +getUpperWidth fp offset terminal = + if offset < terminal then + getUpperWidthHelp fp offset terminal (unsafeIndex fp offset) + else + 0 + + +{-# INLINE getUpperWidthHelp #-} +getUpperWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int +getUpperWidthHelp fp offset terminal word + | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1 + | word < 0xc0 = 0 + | word < 0xe0 = if Char.isUpper (getChar2 fp offset terminal word) then 2 else 0 + | word < 0xf0 = if Char.isUpper (getChar3 fp offset terminal word) then 3 else 0 + | word < 0xf8 = if Char.isUpper (getChar4 fp offset terminal word) then 4 else 0 + | True = 0 + + + +-- LOWER CHARS + + +chompLower :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #) +chompLower fp offset terminal col = + let !width = getLowerWidth fp offset terminal in + if width == 0 then + (# offset, col #) + else + chompInnerChars fp (offset + width) terminal (col + 1) + + +{-# INLINE getLowerWidth #-} +getLowerWidth :: ForeignPtr Word8 -> Int -> Int -> Int +getLowerWidth fp offset terminal = + if offset < terminal then + getLowerWidthHelp fp offset terminal (unsafeIndex fp offset) + else + 0 + + +{-# INLINE getLowerWidthHelp #-} +getLowerWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int +getLowerWidthHelp fp offset terminal word + | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1 + | word < 0xc0 = 0 + | word < 0xe0 = if Char.isLower (getChar2 fp offset terminal word) then 2 else 0 + | word < 0xf0 = if Char.isLower (getChar3 fp offset terminal word) then 3 else 0 + | word < 0xf8 = if Char.isLower (getChar4 fp offset terminal word) then 4 else 0 + | True = 0 + + + +-- INNER CHARS + + +chompInnerChars :: ForeignPtr Word8 -> Int -> Int -> Int -> (# Int, Int #) +chompInnerChars fp !offset terminal !col = + let !width = getInnerWidth fp offset terminal in + if width == 0 then + (# offset, col #) + else + chompInnerChars fp (offset + width) terminal (col + 1) + + +getInnerWidth :: ForeignPtr Word8 -> Int -> Int -> Int +getInnerWidth fp offset terminal = + if offset < terminal then + getInnerWidthHelp fp offset terminal (unsafeIndex fp offset) + else + 0 + + +{-# INLINE getInnerWidthHelp #-} +getInnerWidthHelp :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Int +getInnerWidthHelp fp offset terminal word + | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1 + | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1 + | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1 + | word == 0x5F {- _ -} = 1 + | word < 0xc0 = 0 + | word < 0xe0 = if Char.isAlpha (getChar2 fp offset terminal word) then 2 else 0 + | word < 0xf0 = if Char.isAlpha (getChar3 fp offset terminal word) then 3 else 0 + | word < 0xf8 = if Char.isAlpha (getChar4 fp offset terminal word) then 4 else 0 + | True = 0 + + + +-- EXTRACT CHARACTERS + + +push :: Word8 -> Int -> Int +push word code = + assert (word .&. 0xc0 == 0x80) ( + shiftL code 6 .|. fromEnum (word .&. 0x3f) + ) + + +getChar2 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char +getChar2 fp offset terminal word = + assert (offset + 2 <= terminal) ( + let + !word1 = word .&. 0x1f + !word2 = unsafeIndex fp (offset + 1) + !code = push word2 (fromEnum word1) + in + assert (0x80 <= code) ( + toEnum code + ) + ) + + +getChar3 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char +getChar3 fp offset terminal word = + assert (offset + 3 <= terminal) ( + let + !word1 = word .&. 0x0f + !word2 = unsafeIndex fp (offset + 1) + !word3 = unsafeIndex fp (offset + 2) + !code = push word3 (push word2 (fromEnum word1)) + in + assert ((0x800 <= code && code < 0xd800) || (0xdfff < code && code < 0xfffe)) ( + toEnum code + ) + ) + + +getChar4 :: ForeignPtr Word8 -> Int -> Int -> Word8 -> Char +getChar4 fp offset terminal word = + assert (offset + 4 <= terminal) ( + let + !word1 = word .&. 0x07 + !word2 = unsafeIndex fp (offset + 1) + !word3 = unsafeIndex fp (offset + 2) + !word4 = unsafeIndex fp (offset + 3) + !code = push word4 (push word3 (push word2 (fromEnum word1))) + in + assert (0x10000 <= code && code < 0x110000) ( + toEnum code + ) + ) diff --git a/parser/src/Parse/Primitives/Whitespace.hs b/parser/src/Parse/Primitives/Whitespace.hs new file mode 100644 index 000000000..91c9557a0 --- /dev/null +++ b/parser/src/Parse/Primitives/Whitespace.hs @@ -0,0 +1,223 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} +module Parse.Primitives.Whitespace + ( SPos(..) + , whitespace + , docComment + , chompUntilDocs + ) + where + + +import qualified Data.ByteString.Internal as B +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Word (Word8) + +import Parse.Primitives.Internals (Parser(..), State(..), noError) +import qualified Parse.Primitives.Internals as I +import qualified Parse.Primitives.Symbol as Symbol +import qualified Reporting.Error.Syntax as E +import qualified Reporting.Region as R + + + +-- WHITESPACE + + +newtype SPos = SPos R.Position + + +whitespace :: Parser SPos +whitespace = + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> + case eatSpaces fp offset terminal row col of + Err err -> + cerr err + + Ok newOffset newRow newCol -> + let + !spos = SPos (R.Position newRow newCol) + !newState = State fp newOffset terminal indent newRow newCol ctx + in + cok spos newState noError + + +data Result + = Err E.ParseError + | Ok Int Int Int + + + +-- EAT SPACES + + +eatSpaces :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result +eatSpaces fp offset terminal row col = + if offset >= terminal then + Ok offset row col + + else + case I.unsafeIndex fp offset of + 0x20 {- -} -> + eatSpaces fp (offset + 1) terminal row (col + 1) + + 0x0A {- \n -} -> + eatSpaces fp (offset + 1) terminal (row + 1) 1 + + 0x7B {- { -} -> + eatMultiComment fp offset terminal row col + + 0x2D {- - -} -> + let !offset1 = offset + 1 in + if offset1 < terminal && I.unsafeIndex fp offset1 == 0x2D {- - -} then + eatLineComment fp (offset + 2) terminal row (col + 2) + else + Ok offset row col + + 0x0D {- \r -} -> + eatSpaces fp (offset + 1) terminal row col + + 0x09 {- \t -} -> + Err (E.ParseError row col E.Tab) + + _ -> + Ok offset row col + + + +-- LINE COMMENTS + + +eatLineComment :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result +eatLineComment fp offset terminal row col = + if offset >= terminal then + Ok offset row col + + else + let !word = I.unsafeIndex fp offset in + if word == 0x0A {- \n -} then + eatSpaces fp (offset + 1) terminal (row + 1) 1 + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + eatLineComment fp newOffset terminal row (col + 1) + + + +-- MULTI COMMENTS + + +eatMultiComment :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Result +eatMultiComment fp offset terminal row col = + let + !offset1 = offset + 1 + !offset2 = offset + 2 + in + if offset2 >= terminal then + Ok offset row col + + else + let + !yesDash = I.unsafeIndex fp offset1 == 0x2D {- - -} + !noBar = I.unsafeIndex fp offset2 /= 0x7C {- | -} + in + if yesDash && noBar then + case eatMultiCommentHelp fp offset2 terminal row (col + 2) 1 of + Ok newOffset newRow newCol -> + eatSpaces fp newOffset terminal newRow newCol + + err@(Err _) -> + err + + else + Ok offset row col + + +eatMultiCommentHelp :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> Int -> Result +eatMultiCommentHelp fp offset terminal row col openComments = + if offset >= terminal then + Err (E.ParseError row col E.EndOfFile_Comment) + + else + let !word = I.unsafeIndex fp offset in + if word == 0x0A {- \n -} then + eatMultiCommentHelp fp (offset + 1) terminal (row + 1) 1 openComments + + else if word == 0x2D {- - -} && I.isWord fp (offset + 1) terminal 0x7D {- } -} then + if openComments == 1 then + Ok (offset + 2) row (col + 2) + else + eatMultiCommentHelp fp (offset + 2) terminal row (col + 2) (openComments - 1) + + else if word == 0x7B {- { -} && I.isWord fp (offset + 1) terminal 0x2D {- - -} then + eatMultiCommentHelp fp (offset + 2) terminal row (col + 2) (openComments + 1) + + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + eatMultiCommentHelp fp newOffset terminal row (col + 1) openComments + + + +-- DOCUMENTATION COMMENT + + +docComment :: Parser B.ByteString +docComment = + do Symbol.elmDocCommentOpen + Parser $ \(State fp offset terminal indent row col ctx) cok cerr _ _ -> + case eatMultiCommentHelp fp offset terminal row col 1 of + Err err -> + cerr err + + Ok newOffset newRow newCol -> + let + !comment = B.PS fp offset (newOffset - offset - 2) + !newState = State fp newOffset terminal indent newRow newCol ctx + in + cok comment newState noError + + + +-- PARSING DOCS + + +chompUntilDocs :: Parser Bool +chompUntilDocs = + Parser $ \(State fp offset terminal indent row col ctx) cok _ _ _ -> + let + (# isStart, newOffset, newRow, newCol #) = + eatDocs fp offset terminal row col + + !newState = + State fp newOffset terminal indent newRow newCol ctx + in + cok isStart newState noError + + +eatDocs :: ForeignPtr Word8 -> Int -> Int -> Int -> Int -> (# Bool, Int, Int, Int #) +eatDocs fp offset terminal row col = + if offset >= terminal then + (# False, offset, row, col #) + + else if isDocsStart fp offset terminal then + (# True, offset + 5, row, col + 5 #) + + else + let !word = I.unsafeIndex fp offset in + if word == 0x0A {- \n -} then + eatDocs fp (offset + 1) terminal (row + 1) 1 + + else + let !newOffset = offset + I.getCharWidth fp offset terminal word in + eatDocs fp newOffset terminal row (col + 1) + + +isDocsStart :: ForeignPtr Word8 -> Int -> Int -> Bool +isDocsStart = + let (B.PS dfp doff dlen) = docsStart in + I.isSubstring dfp doff dlen + + +{-# NOINLINE docsStart #-} +docsStart :: B.ByteString +docsStart = + "@docs" diff --git a/parser/src/Parse/State.hs b/parser/src/Parse/State.hs deleted file mode 100644 index 224140230..000000000 --- a/parser/src/Parse/State.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Parse.State where - - -data State = State - { newline :: [Bool] - } - - -init :: State -init = - State - { newline = [False] - } - - -setNewline :: State -> State -setNewline state = - case newline state of - [] -> state - (_:rest) -> state { newline = (True:rest) } - - -pushNewlineContext :: State -> State -pushNewlineContext state = - state { newline = (False:(newline state)) } - - -popNewlineContext :: State -> State -popNewlineContext state = - case newline state of - [] -> state - (_:[]) -> state - (last:next:rest) -> state { newline = (last || next):rest } - - -sawNewline :: State -> Bool -sawNewline state = - case newline state of - [] -> False - (b:_) -> b diff --git a/parser/src/Parse/Whitespace.hs b/parser/src/Parse/Whitespace.hs index 3cb6f5504..dbd5b1f88 100644 --- a/parser/src/Parse/Whitespace.hs +++ b/parser/src/Parse/Whitespace.hs @@ -2,12 +2,17 @@ module Parse.Whitespace where import AST.V0_16 import qualified Cheapskate.Types as Markdown +import qualified Data.ByteString as ByteString import qualified Data.Char as Char +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8) import Parse.IParser import qualified Parse.Markdown as Markdown -import qualified Parse.State as State -import qualified Reporting.Error.Syntax as Syntax -import Text.Parsec hiding (newline, spaces, State) +-- import qualified Reporting.Error.Syntax as Syntax +import Parse.Primitives (try) +import Parse.Primitives.Internals (Parser(..), State(..)) +import Parse.ParsecAdapter (string, (<|>), many, many1, choice, option, char, eof, lookAhead, notFollowedBy, anyWord8) +-- import Text.Parsec hiding (newline, spaces, State) padded :: IParser a -> IParser (Comments, a, Comments) @@ -27,7 +32,7 @@ spaces = blank <|> (const [CommentTrickOpener] <$> (try $ string "{--}")) <|> comment - Syntax.whitespace + -- Syntax.whitespace in concat <$> many1 space @@ -61,31 +66,37 @@ whitespace = freshLine :: IParser Comments freshLine = - concat <$> (try ((++) <$> many1 newline <*> many space_nl) <|> try (many1 space_nl)) Syntax.freshLine + concat <$> (try ((++) <$> many1 newline <*> many space_nl) <|> try (many1 space_nl)) -- Syntax.freshLine where space_nl = try $ (++) <$> spaces <*> (concat <$> many1 newline) newline :: IParser Comments newline = - (simpleNewline >> return []) <|> ((\x -> [x]) <$> lineComment) Syntax.newline + (simpleNewline >> return []) <|> ((\x -> [x]) <$> lineComment) -- Syntax.newline simpleNewline :: IParser () simpleNewline = do _ <- try (string "\r\n") <|> string "\n" - updateState State.setNewline return () trackNewline :: IParser a -> IParser (a, Multiline) -trackNewline parser = - do - updateState State.pushNewlineContext - a <- parser - state <- getState - updateState State.popNewlineContext - return (a, if State.sawNewline state then SplitAll else JoinAll) +trackNewline (Parser parser) = + Parser $ \state@(State _ _ _ _ row _ _) cok _ eok err -> + let + cok' a newState@(State _ _ _ _ newRow _ _) e = + if newRow > row + then cok (a, SplitAll) newState e + else cok (a, JoinAll) newState e + + eok' a newState e = + -- Nothing was consumed, so there cannot have been a newline + eok (a, JoinAll) newState e + + in + parser state cok' err eok' err lineComment :: IParser Comment @@ -158,19 +169,19 @@ closeComment keepClosingPunc = uncurry (++) <$> anyUntil (choice - [ try ((\a b -> if keepClosingPunc then concat (a ++ [b]) else "") <$> many (string " ") <*> string "-}") "the end of a comment -}" + [ try ((\a b -> if keepClosingPunc then concat (a ++ [b]) else "") <$> many (string " ") <*> string "-}") -- "the end of a comment -}" , concat <$> sequence [ try (string "{-"), closeComment True, closeComment keepClosingPunc] ]) anyUntil :: IParser a -> IParser (String, a) anyUntil end = - go "" + go [] where next pre = do - nextChar <- anyChar - go (nextChar : pre) + nextByte <- anyWord8 + go (nextByte : pre) go pre = - ((,) (reverse pre) <$> end) <|> next pre + ((,) (Text.unpack . decodeUtf8 . ByteString.pack $ reverse pre) <$> end) <|> next pre diff --git a/parser/src/Reporting/Annotation.hs b/parser/src/Reporting/Annotation.hs index 4238450a9..ef8fbd67d 100644 --- a/parser/src/Reporting/Annotation.hs +++ b/parser/src/Reporting/Annotation.hs @@ -1,62 +1,118 @@ -module Reporting.Annotation where +{-# OPTIONS_GHC -Wall #-} +module Reporting.Annotation + ( Located(..) + , Position(..) + , Region(..) + , traverse + , toValue + , merge + , at + , toRegion + , mergeRegions + , zero + , one + , Strippable, stripRegion + ) + where -import Prelude hiding (map) -import qualified Reporting.Region as R -import qualified Data.String as String +import Prelude hiding (traverse) +import Control.Monad (liftM2) +import Data.Binary (Binary, get, put) +import Data.Word (Word16) + + + +-- LOCATED --- ANNOTATION data Located a = - A R.Region a - deriving (Eq) + At Region a -- TODO see if unpacking region is helpful + deriving (Eq, Show) -instance (Show a) => Show (Located a) where - showsPrec p (A r a) = showParen (p > 10) $ - showString $ String.unwords - [ "at" - , show (R.line $ R.start r) - , show (R.column $ R.start r) - , show (R.line $ R.end r) - , show (R.column $ R.end r) - , showsPrec 99 a "" - ] +instance Functor Located where + fmap f (At region a) = + At region (f a) --- CREATE +traverse :: (Functor f) => (a -> f b) -> Located a -> f (Located b) +traverse func (At region value) = + At region <$> func value -at :: R.Position -> R.Position -> a -> Located a -at start end value = - A (R.Region start end) value + +toValue :: Located a -> a +toValue (At _ value) = + value merge :: Located a -> Located b -> value -> Located value -merge (A region1 _) (A region2 _) value = - A (R.merge region1 region2) value +merge (At r1 _) (At r2 _) value = + At (mergeRegions r1 r2) value + + + +-- POSITION + + +data Position = + Position + {-# UNPACK #-} !Word16 + {-# UNPACK #-} !Word16 + deriving (Eq, Show) + + +at :: Position -> Position -> a -> Located a +at start end a = + At (Region start end) a + + + +-- REGION + + +data Region = Region Position Position + deriving (Eq, Show) + + +toRegion :: Located a -> Region +toRegion (At region _) = + region + + +mergeRegions :: Region -> Region -> Region +mergeRegions (Region start _) (Region _ end) = + Region start end + + +zero :: Region +zero = + Region (Position 0 0) (Position 0 0) + + +one :: Region +one = + Region (Position 1 1) (Position 1 1) -sameAs :: Located a -> b -> Located b -sameAs (A annotation _) value = - A annotation value +instance Binary Region where + put (Region a b) = put a >> put b + get = liftM2 Region get get --- MANIPULATE +instance Binary Position where + put (Position a b) = put a >> put b + get = liftM2 Position get get -map :: (a -> b) -> Located a -> Located b -map f (A annotation value) = - A annotation (f value) -drop :: Located a -> a -drop (A _ value) = - value +-- FOR ELM-FORMAT class Strippable a where - stripRegion :: a -> a + stripRegion :: a -> a instance Strippable (Located a) where - stripRegion (A _ value) = - A (R.Region (R.Position 0 0) (R.Position 0 0)) value + stripRegion (At _ value) = + At (Region (Position 0 0) (Position 0 0)) value diff --git a/parser/src/Reporting/Doc.hs b/parser/src/Reporting/Doc.hs new file mode 100644 index 000000000..1faa9ba9f --- /dev/null +++ b/parser/src/Reporting/Doc.hs @@ -0,0 +1,412 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +module Reporting.Doc + ( P.Doc + , (P.<+>), (<>) + , P.align, P.cat, P.empty, P.fill, P.fillSep, P.hang + , P.hcat, P.hsep, P.indent, P.sep, P.vcat + , P.red, P.cyan, P.magenta, P.green, P.blue, P.black, P.yellow + , P.dullred, P.dullcyan, P.dullyellow + -- + , fromChars + , fromName + , fromVersion + , fromPackage + , fromInt + -- + , toAnsi, toString, toLine + -- , encode + + , stack, reflow, commaSep + , toSimpleNote, toSimpleHint, toFancyHint + , link, fancyLink, reflowLink, makeLink, makeNakedLink + , args, moreArgs + , ordinal, intToOrdinal + , cycle + ) + where + + +import Prelude hiding (cycle) +import qualified Data.List as List +import Data.Monoid ((<>)) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Elm.Name as N +import qualified System.Console.ANSI.Types as Ansi +import System.IO (Handle) +import qualified Text.PrettyPrint.ANSI.Leijen as P + +import qualified Data.Index as Index +-- import qualified Elm.Compiler.Version as Compiler +-- import qualified Elm.Package as Pkg +-- import qualified Json.Encode as E + + + +-- FROM + + +fromChars :: String -> P.Doc +fromChars = + P.text + + +fromName :: Name.Name -> P.Doc +fromName name = + P.text (Name.toChars name) + + +fromVersion :: V.Version -> P.Doc +fromVersion vsn = + P.text (V.toChars vsn) + + +fromPackage :: Pkg.Name -> P.Doc +fromPackage pkg = + P.text (Pkg.toChars pkg) + + +fromInt :: Int -> P.Doc +fromInt n = + P.text (show n) + + + +-- TO STRING + + +toAnsi :: Handle -> P.Doc -> IO () +toAnsi handle doc = + P.displayIO handle (P.renderPretty 1 80 doc) + + +toString :: P.Doc -> String +toString doc = + P.displayS (P.renderPretty 1 80 (P.plain doc)) "" + + +toLine :: P.Doc -> String +toLine doc = + P.displayS (P.renderPretty 1 (div maxBound 2) (P.plain doc)) "" + + + +-- FORMATTING + + +stack :: [P.Doc] -> P.Doc +stack docs = + P.vcat (List.intersperse "" docs) + + +reflow :: String -> P.Doc +reflow paragraph = + P.fillSep (map P.text (words paragraph)) + + +commaSep :: P.Doc -> (P.Doc -> P.Doc) -> [P.Doc] -> [P.Doc] +commaSep conjunction addStyle names = + case names of + [name] -> + [ addStyle name ] + + [name1,name2] -> + [ addStyle name1, conjunction, addStyle name2 ] + + _ -> + map (\name -> addStyle name <> ",") (init names) + ++ + [ conjunction + , addStyle (last names) + ] + + + +-- HINTS + + +toSimpleNote :: String -> P.Doc +toSimpleNote message = + P.fillSep ((P.underline "Note" <> ":") : map P.text (words message)) + + +toSimpleHint :: String -> P.Doc +toSimpleHint message = + toFancyHint (map P.text (words message)) + + +toFancyHint :: [P.Doc] -> P.Doc +toFancyHint chunks = + P.fillSep (P.underline "Hint" <> ":" : chunks) + + + +-- LINKS + + +link :: P.Doc -> String -> String -> String -> P.Doc +link word before fileName after = + P.fillSep $ + (P.underline word <> ":") + : map P.text (words before) + ++ P.text (makeLink fileName) + : map P.text (words after) + + +fancyLink :: P.Doc -> [P.Doc] -> String -> [P.Doc] -> P.Doc +fancyLink word before fileName after = + P.fillSep $ + (P.underline word <> ":") : before ++ P.text (makeLink fileName) : after + + +makeLink :: String -> String +makeLink fileName = + -- TODO: set this up somehow + -- " Pkg.versionToString Compiler.version <> "/" <> fileName <> ">" + " "0.19" <> "/" <> fileName <> ">" + + +makeNakedLink :: String -> String +makeNakedLink fileName = + -- TODO: set this up somehow + -- "https://elm-lang.org/" <> Pkg.versionToString Compiler.version <> "/" <> fileName + "https://elm-lang.org/" <> "0.19" <> "/" <> fileName + + +reflowLink :: String -> String -> String -> P.Doc +reflowLink before fileName after = + P.fillSep $ + map P.text (words before) + ++ P.text (makeLink fileName) + : map P.text (words after) + + + +-- HELPERS + + +args :: Int -> String +args n = + show n <> if n == 1 then " argument" else " arguments" + + +moreArgs :: Int -> String +moreArgs n = + show n <> " more" <> if n == 1 then " argument" else " arguments" + + +ordinal :: Index.ZeroBased -> String +ordinal index = + intToOrdinal (Index.toHuman index) + + +intToOrdinal :: Int -> String +intToOrdinal number = + let + remainder10 = + number `mod` 10 + + remainder100 = + number `mod` 100 + + ending + | remainder100 `elem` [11..13] = "th" + | remainder10 == 1 = "st" + | remainder10 == 2 = "nd" + | remainder10 == 3 = "rd" + | otherwise = "th" + in + show number <> ending + + + +cycle :: Int -> [N.Name] -> P.Doc +cycle indent names = + let + topLine = "┌─────┐" + nameLine name = "│ " <> P.dullyellow (fromName name) + midLine = "│ ↓" + bottomLine = "└─────┘" + in + P.indent indent $ P.vcat $ + topLine : List.intersperse midLine (map nameLine names) ++ [ bottomLine ] + + + +-- JSON + + +-- encode :: P.Doc -> E.Value +-- encode doc = +-- E.array (toJsonHelp noStyle [] (P.renderPretty 1 80 doc)) + + +data Style = + Style + { _bold :: Bool + , _underline :: Bool + , _color :: Maybe Color + } + + +noStyle :: Style +noStyle = + Style False False Nothing + + +data Color + = Red + | RED + | Magenta + | MAGENTA + | Yellow + | YELLOW + | Green + | GREEN + | Cyan + | CYAN + | Blue + | BLUE + | Black + | BLACK + | White + | WHITE + + +-- toJsonHelp :: Style -> [TB.Builder] -> P.SimpleDoc -> [E.Value] +-- toJsonHelp style revChunks simpleDoc = +-- case simpleDoc of +-- P.SFail -> +-- error $ +-- "according to the main implementation, @SFail@ can not\ +-- \ appear uncaught in a rendered @SimpleDoc@" + +-- P.SEmpty -> +-- [ encodeChunks style revChunks ] + +-- P.SChar char rest -> +-- toJsonHelp style (TB.singleton char : revChunks) rest + +-- P.SText _ string rest -> +-- toJsonHelp style (TB.fromString string : revChunks) rest + +-- P.SLine indent rest -> +-- toJsonHelp style (spaces indent : "\n" : revChunks) rest + +-- P.SSGR sgrs rest -> +-- encodeChunks style revChunks : toJsonHelp (sgrToStyle sgrs style) [] rest + + +spaces :: Int -> TB.Builder +spaces n = + TB.fromText (Text.replicate n " ") + + +sgrToStyle :: [Ansi.SGR] -> Style -> Style +sgrToStyle sgrs style@(Style bold underline color) = + case sgrs of + [] -> + style + + sgr : rest -> + sgrToStyle rest $ + case sgr of + Ansi.Reset -> noStyle + Ansi.SetConsoleIntensity i -> Style (isBold i) underline color + Ansi.SetItalicized _ -> style + Ansi.SetUnderlining u -> Style bold (isUnderline u) color + Ansi.SetBlinkSpeed _ -> style + Ansi.SetVisible _ -> style + Ansi.SetSwapForegroundBackground _ -> style + Ansi.SetColor l i c -> Style bold underline (toColor l i c) + Ansi.SetRGBColor _ _ -> style + + +isBold :: Ansi.ConsoleIntensity -> Bool +isBold intensity = + case intensity of + Ansi.BoldIntensity -> True + Ansi.FaintIntensity -> False + Ansi.NormalIntensity -> False + + +isUnderline :: Ansi.Underlining -> Bool +isUnderline underlining = + case underlining of + Ansi.SingleUnderline -> True + Ansi.DoubleUnderline -> False + Ansi.NoUnderline -> False + + +toColor :: Ansi.ConsoleLayer -> Ansi.ColorIntensity -> Ansi.Color -> Maybe Color +toColor layer intensity color = + case layer of + Ansi.Background -> + Nothing + + Ansi.Foreground -> + let + pick dull vivid = + case intensity of + Ansi.Dull -> dull + Ansi.Vivid -> vivid + in + Just $ + case color of + Ansi.Red -> pick Red RED + Ansi.Magenta -> pick Magenta MAGENTA + Ansi.Yellow -> pick Yellow YELLOW + Ansi.Green -> pick Green GREEN + Ansi.Cyan -> pick Cyan CYAN + Ansi.Blue -> pick Blue BLUE + Ansi.White -> pick White WHITE + Ansi.Black -> pick Black BLACK + + +-- encodeChunks :: Style -> [TB.Builder] -> E.Value +-- encodeChunks (Style bold underline color) revChunks = +-- let +-- text = +-- case revChunks of +-- [] -> +-- Text.empty + +-- c:cs -> +-- TL.toStrict $ TB.toLazyText $ +-- List.foldl' (\builder chunk -> chunk <> builder) c cs +-- in +-- case color of +-- Nothing | not bold && not underline -> +-- E.text text + +-- _ -> +-- E.object +-- [ ("bold", E.bool bold) +-- , ("underline", E.bool underline) +-- , ("color", maybe E.null encodeColor color) +-- , ("string", E.text text) +-- ] + + +-- encodeColor :: Color -> E.Value +-- encodeColor color = +-- E.text $ +-- case color of +-- Red -> "red" +-- RED -> "RED" +-- Magenta -> "magenta" +-- MAGENTA -> "MAGENTA" +-- Yellow -> "yellow" +-- YELLOW -> "YELLOW" +-- Green -> "green" +-- GREEN -> "GREEN" +-- Cyan -> "cyan" +-- CYAN -> "CYAN" +-- Blue -> "blue" +-- BLUE -> "BLUE" +-- Black -> "black" +-- BLACK -> "BLACK" +-- White -> "white" +-- WHITE -> "WHITE" diff --git a/parser/src/Reporting/Error.hs b/parser/src/Reporting/Error.hs index 20c5a4903..f6116888a 100644 --- a/parser/src/Reporting/Error.hs +++ b/parser/src/Reporting/Error.hs @@ -1,66 +1,57 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE OverloadedStrings #-} -module Reporting.Error where +module Reporting.Error + ( Error(..) + , toReports + ) + where -import Data.Aeson ((.=)) -import qualified Data.Aeson as Json -import Prelude hiding (print) -import qualified Reporting.Annotation as A +-- import qualified Reporting.Error.Canonicalize as Canonicalize import qualified Reporting.Error.Docs as Docs +-- import qualified Reporting.Error.Main as Main +-- import qualified Reporting.Error.Pattern as Pattern import qualified Reporting.Error.Syntax as Syntax +-- import qualified Reporting.Error.Type as Type +import qualified Reporting.Render.Code as Code +-- import qualified Reporting.Render.Type.Localizer as L import qualified Reporting.Report as Report + -- ALL POSSIBLE ERRORS + data Error - = Syntax Syntax.Error - | Docs Docs.Error - deriving (Eq, Show) + = Syntax Syntax.Error + -- | Canonicalize Canonicalize.Error + -- | Type L.Localizer [Type.Error] + -- | Main L.Localizer Main.Error + -- | Pattern [Pattern.Error] + | Docs Docs.Error + -- TO REPORT -toReport :: Error -> Report.Report -toReport err = + +toReports :: Code.Source -> Error -> [Report.Report] +toReports source err = case err of Syntax syntaxError -> - Syntax.toReport syntaxError - - Docs docsError -> - Docs.toReport docsError + [Syntax.toReport source syntaxError] + -- Canonicalize canonicalizeError -> + -- [Canonicalize.toReport source canonicalizeError] --- TO STRING + -- Type localizer typeErrors -> + -- map (Type.toReport source localizer) typeErrors -toString :: String -> String -> A.Located Error -> String -toString location source (A.A region err) = - Report.toString location region (toReport err) source + -- Main localizer mainError -> + -- [Main.toReport localizer source mainError] + -- Pattern patternErrors -> + -- map (Pattern.toReport source) patternErrors -print :: String -> String -> A.Located Error -> IO () -print location source (A.A region err) = - Report.printError location region (toReport err) source - - --- TO JSON - -toJson :: FilePath -> A.Located Error -> Json.Value -toJson filePath (A.A region err) = - let - (maybeRegion, additionalFields) = - case err of - Syntax syntaxError -> - Report.toJson [] (Syntax.toReport syntaxError) - - Docs docsError -> - Report.toJson [] (Docs.toReport docsError) - in - Json.object $ - [ "file" .= filePath - , "region" .= region - , "subregion" .= maybeRegion - , "type" .= ("error" :: String) - ] - ++ additionalFields + Docs docsError -> + [Docs.toReport source docsError] diff --git a/parser/src/Reporting/Error/Docs.hs b/parser/src/Reporting/Error/Docs.hs index 21c0d42f8..924337c01 100644 --- a/parser/src/Reporting/Error/Docs.hs +++ b/parser/src/Reporting/Error/Docs.hs @@ -1,61 +1,140 @@ {-# OPTIONS_GHC -Wall #-} -module Reporting.Error.Docs where +{-# LANGUAGE OverloadedStrings #-} +module Reporting.Error.Docs + ( Error(..) + , toReport + ) + where -import qualified Reporting.Error.Helpers as Help + +import qualified Elm.Name as N +import Reporting.Doc ((<>)) +import qualified Reporting.Doc as D +import qualified Reporting.Region as R +import qualified Reporting.Render.Code as Code import qualified Reporting.Report as Report + data Error - = NoDocs - | OnlyInDocs String [String] - | OnlyInExports [String] - | NoComment String - | NoType String + = NoDocs R.Region + | ImplicitExposing R.Region + | Duplicate N.Name R.Region R.Region + | OnlyInDocs N.Name R.Region + | OnlyInExports N.Name R.Region + | NoComment N.Name R.Region + | NoAnnotation N.Name R.Region + -- TO REPORT -toReport :: Error -> Report.Report -toReport err = + +toReport :: Code.Source -> Error -> Report.Report +toReport source err = case err of - NoDocs -> - Report.simple "DOCUMENTATION ERROR" - ( "You must have a documentation comment between the module declaration and the\n" - ++ "imports." + NoDocs region -> + Report.Report "NO DOCS" region [] $ + D.stack + [ + D.reflow $ + "You must have a documentation comment between the module\ + \ declaration and the imports." + , + D.reflow + "Learn more at " + ] + + ImplicitExposing region -> + Report.Report "IMPLICIT EXPOSING" region [] $ + D.stack + [ + D.reflow $ + "I need you to be explicit about what this module exposes:" + , + D.reflow $ + "A great API usually hides some implementation details, so it is rare that\ + \ everything in the file should be exposed. And requiring package authors\ + \ to be explicit about this is a way of adding another quality check before\ + \ code gets published. So as you write out the public API, ask yourself if\ + \ it will be easy to understand as people read the documentation!" + ] + + Duplicate name r1 r2 -> + Report.Report "DUPLICATE DOCS" r2 [] $ + Report.toCodePair source r1 r2 + ( + D.reflow $ + "There can only be one `" <> N.toString name + <> "` in your module documentation, but it is listed twice:" + , + "Remove one of them!" + ) + ( + D.reflow $ + "There can only be one `" <> N.toString name + <> "` in your module documentation, but I see two. One here:" + , + "And another one over here:" + , + "Remove one of them!" ) - "Learn how at " - - OnlyInDocs name suggestions -> - Report.simple "DOCUMENTATION ERROR" - ("Your module documentation includes `" ++ name ++ "` which is not exported.") - ("Is it misspelled? Should it be exported? " ++ Help.maybeYouWant suggestions) - - OnlyInExports names -> - Report.simple - "DOCUMENTATION ERROR" - ( "The following exports do not appear in your module documentation:\n" - ++ concatMap ("\n " ++) names + + OnlyInDocs name region -> + Report.Report "DOCS MISTAKE" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "I do not see `" <> N.toString name + <> "` in the `exposing` list, but it is in your module documentation:" + , + D.reflow $ + "Does it need to be added to the `exposing` list as well? Or maybe you removed `" + <> N.toString name <> "` and forgot to delete it here?" ) - ( "All exports must be listed in the module documentation after a @docs keyword.\n" - ++ "Learn how at " + + OnlyInExports name region -> + Report.Report "DOCS MISTAKE" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "I do not see `" <> N.toString name + <> "` in your module documentation, but it is in your `exposing` list:" + , + D.stack + [ D.reflow $ + "Add a line like `@docs " <> N.toString name + <> "` to your module documentation!" + , D.link "Note" "See" "docs" "for more guidance on writing high quality docs." + ] ) - NoComment name -> - Report.simple "DOCUMENTATION ERROR" - ("The value `" ++ name ++ "` does not have a documentation comment.") - ( "Documentation comments start with {-| and end with -}. They should provide a\n" - ++ "clear description of how they work, and ideally a small code example. This is\n" - ++ "extremely valuable for users checking out your package!\n\n" - ++ "If you think the docs are clearer without any words, you can use an empty\n" - ++ "comment {-|-} which should be used sparingly. Maybe you have a section of 20\n" - ++ "values all with the exact same type. The docs may read better if they are all\n" - ++ "described in one place.\n\n" - ++ "Learn more at " + NoComment name region -> + Report.Report "NO DOCS" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "The `" <> N.toString name <> "` definition does not have a documentation comment." + , + D.stack + [ D.reflow $ + "Add documentation with nice examples of how to use it!" + , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" + ] ) - NoType name -> - Report.simple "MISSING ANNOTATION" - ("The value `" ++ name ++ "` does not have a type annotation.") - ( "Adding type annotations is best practice and it gives you a chance to name\n" - ++ "types and type variables so they are as easy as possible to understand!" + NoAnnotation name region -> + Report.Report "NO TYPE ANNOTATION" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "The `" <> N.toString name <> "` definition does not have a type annotation." + , + D.stack + [ D.reflow $ + "I use the type variable names from your annotations when generating docs. So if\ + \ you say `Html msg` in your type annotation, I can use `msg` in the docs and make\ + \ them a bit clearer. So add an annotation and try to use nice type variables!" + , D.link "Note" "Read" "docs" "for more advice on writing great docs. There are a couple important tricks!" + ] ) diff --git a/parser/src/Reporting/Error/Helpers.hs b/parser/src/Reporting/Error/Helpers.hs index e2d4a1585..3a2aae0cd 100644 --- a/parser/src/Reporting/Error/Helpers.hs +++ b/parser/src/Reporting/Error/Helpers.hs @@ -3,28 +3,28 @@ module Reporting.Error.Helpers where import Data.Function (on) import qualified Data.List as List -import qualified Text.EditDistance as Dist +-- import qualified Text.EditDistance as Dist import Elm.Utils ((|>)) -- NEARBY NAMES -nearbyNames :: (a -> String) -> a -> [a] -> [a] -nearbyNames format name names = - let editDistance = - if length (format name) < 3 then 1 else 2 - in - names - |> map (\x -> (distance (format name) (format x), x)) - |> List.sortBy (compare `on` fst) - |> filter ( (<= editDistance) . abs . fst ) - |> map snd - - -distance :: String -> String -> Int -distance x y = - Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y +-- nearbyNames :: (a -> String) -> a -> [a] -> [a] +-- nearbyNames format name names = +-- let editDistance = +-- if length (format name) < 3 then 1 else 2 +-- in +-- names +-- |> map (\x -> (distance (format name) (format x), x)) +-- |> List.sortBy (compare `on` fst) +-- |> filter ( (<= editDistance) . abs . fst ) +-- |> map snd + + +-- distance :: String -> String -> Int +-- distance x y = +-- Dist.restrictedDamerauLevenshteinDistance Dist.defaultEditCosts x y maybeYouWant :: [String] -> String diff --git a/parser/src/Reporting/Error/Syntax.hs b/parser/src/Reporting/Error/Syntax.hs index e8c9876d2..f42d0fce0 100644 --- a/parser/src/Reporting/Error/Syntax.hs +++ b/parser/src/Reporting/Error/Syntax.hs @@ -1,192 +1,787 @@ {-# OPTIONS_GHC -Wall #-} -module Reporting.Error.Syntax where - -import AST.V0_16 -import qualified Data.List as List +{-# LANGUAGE OverloadedStrings #-} +module Reporting.Error.Syntax + ( Error(..) + , ParseError(..) + , Problem(..), Theory(..) + , EscapeProblem(..) + , ContextStack, Context(..) + , BadOp(..), Next(..) + , toReport + ) + where + + +import Data.Monoid ((<>)) import qualified Data.Set as Set -import qualified Text.Parsec.Error as Parsec +import qualified Data.Text as Text -import qualified AST.Variable as Var +import qualified Elm.Name as N +import qualified Reporting.Doc as D +import qualified Reporting.Region as R +import qualified Reporting.Render.Code as Code import qualified Reporting.Report as Report -data Error - = Parse [Parsec.Message] - | InfixDuplicate Var.Ref - | TypeWithoutDefinition String - | PortWithoutAnnotation String - | UnexpectedPort - | DuplicateValueDeclaration String - | DuplicateTypeDeclaration String - | DuplicateDefinition String - deriving (Eq) +-- ALL SYNTAX ERRORS + + +data Error + = CommentOnNothing R.Region + | UnexpectedPort R.Region N.Name + | TypeWithBadDefinition R.Region N.Name N.Name + | TypeWithoutDefinition R.Region N.Name + | Parse R.Region (Maybe R.Region) Problem + + + +-- PARSE ERRORS + + +data ParseError = ParseError !Int !Int !Problem + + +data Problem + = Tab + | EndOfFile_Comment + | EndOfFile_Shader + | EndOfFile_String + | EndOfFile_MultiString + | EndOfFile_Char + | NewLineInString + | NewLineInChar + | BadEscape Int EscapeProblem + | BadChar Int + | BadNumberDot Int + | BadNumberEnd + | BadNumberExp + | BadNumberHex + | BadNumberZero + | FloatInPattern + | BadShader Text.Text + | BadUnderscore Int + | BadOp BadOp ContextStack + | Theories ContextStack [Theory] + + +data EscapeProblem + = UnknownEscape + | UnicodeSyntax + | UnicodeRange + | UnicodeLength Int String + + +data BadOp = HasType | Equals | Arrow | Pipe | Dot + + +data Theory + = Expecting Next + | Keyword String + | Symbol String + | LowVar + | CapVar + | InfixOp + | Digit + | BadSpace + deriving (Eq, Ord) + + +data Next + = Decl + | Expr + | AfterOpExpr N.Name + | ElseBranch + | Arg + | Pattern + | Type + | Listing + | Exposing + deriving (Eq, Ord) + + +type ContextStack = [(Context, R.Position)] + + +data Context + = ExprIf + | ExprLet + | ExprFunc + | ExprCase + | ExprList + | ExprTuple + | ExprRecord + ---------------- + | Definition N.Name + | Annotation N.Name + ---------------- + | TypeTuple + | TypeRecord + ---------------- + | PatternList + | PatternTuple + | PatternRecord + ---------------- + | Module + | Import + | TypeUnion + | TypeAlias + | Infix + | Port + deriving (Eq, Ord) -instance Show Error where - show e = - show $ toReport e -- TO REPORT -toReport :: Error -> Report.Report -toReport err = + +toReport :: Code.Source -> Error -> Report.Report +toReport source err = case err of - Parse messages -> - parseErrorReport messages - - InfixDuplicate op -> - Report.simple - "INFIX OVERLAP" - ("The infix declarations for " ++ operator ++ " must be removed.") - ("The precedence and associativity can only be set in one place, and\n" - ++ "this information has already been set somewhere else." - ) - where - operator = - case op of - Var.VarRef _namespace (LowercaseIdentifier name) -> "`" ++ name ++ "`" - Var.TagRef _namespace (UppercaseIdentifier name) -> "`" ++ name ++ "`" - Var.OpRef (SymbolIdentifier name) -> "(" ++ name ++ ")" - - TypeWithoutDefinition valueName -> - Report.simple - "MISSING DEFINITION" - ("There is a type annotation for `" ++ valueName ++ "` but there" - ++ " is no corresponding definition!" - ) - ("Directly below the type annotation, put a definition like:\n\n" - ++ " " ++ valueName ++ " = 42" + CommentOnNothing region -> + Report.Report "STRAY COMMENT" region [] $ + Report.toCodeSnippet source region Nothing + ( + "This documentation comment is not followed by anything." + , + D.reflow $ + "All documentation comments need to be right above the declaration they\ + \ describe. Maybe some code got deleted or commented out by accident? Or\ + \ maybe this comment is here by accident?" ) - PortWithoutAnnotation portName -> - Report.simple - "PORT ERROR" - ("Port `" ++ portName ++ "` does not have a type annotation!") - ("Directly above the port definition, I need something like this:\n\n" - ++ " port " ++ portName ++ " : Signal Int" + UnexpectedPort region name -> + Report.Report "BAD PORT" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "You are declaring port `" <> N.toString name <> "` in a normal module." + , + D.stack + [ "It needs to be in a `port` module." + , D.link "Hint" + "Ports are not a traditional FFI for calling JS functions directly. They need a different mindset! Read" + "ports" + "to learn how to use ports effectively." + ] ) - - UnexpectedPort -> - Report.simple - "PORT ERROR" - "This module has ports, but ports can only appear in the main module." - ( "Ports in library code would create hidden dependencies where importing a\n" - ++ "module could bring in constraints not captured in the public API. Furthermore,\n" - ++ "if the module is imported twice, do we send values out the port twice?" + TypeWithBadDefinition region annName defName -> + Report.Report "ANNOTATION MISMATCH" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "I see a `" <> N.toString annName + <> "` annotation, but it is followed by a `" + <> N.toString defName <> "` definition." + , + D.fillSep + ["The","annotation","and","definition","names","must","match!" + ,"Is","there","a","typo","between" + , D.dullyellow (D.fromName annName) + ,"and" + , D.dullyellow (D.fromName defName) <> "?" + ] ) - DuplicateValueDeclaration name -> - Report.simple - "DUPLICATE DEFINITION" - ("Naming multiple top-level values `" ++ name ++ "` makes things\n" - ++ "ambiguous. When you say `" ++ name ++ "` which one do you want?" - ) - ("Find all the top-level values named `" ++ name ++ "` and\n" - ++ "do some renaming. Make sure the names are distinct!" + TypeWithoutDefinition region name -> + Report.Report "MISSING DEFINITION" region [] $ + Report.toCodeSnippet source region Nothing + ( + D.reflow $ + "There is a type annotation for `" <> N.toString name + <> "` but there is no corresponding definition!" + , + "Directly below the type annotation, put a definition like:\n\n" + <> " " <> D.fromName name <> " = 42" ) - DuplicateTypeDeclaration name -> - Report.simple - "DUPLICATE DEFINITION" - ("Naming multiple types `" ++ name ++ "` makes things ambiguous\n" - ++ "When you say `" ++ name ++ "` which one do you want?" - ) - ("Find all the types named `" ++ name ++ "` and\n" - ++ "do some renaming. Make sure the names are distinct!" + Parse region subRegion problem -> + Report.Report "PARSE ERROR" (maybe region id subRegion) [] $ + Report.toCodeSnippet source region subRegion $ + problemToDocs problem + + + +-- PARSE ERROR TO DOCS + + +problemToDocs :: Problem -> (D.Doc, D.Doc) +problemToDocs problem = + case problem of + Tab -> + ( + "I ran into a tab, but tabs are not allowed in Elm files." + , + "Replace the tab with spaces." + ) + + EndOfFile_Comment -> + ( + "I got to the end of the file while parsing a multi-line comment." + , + D.stack + [ D.reflow $ + "Multi-line comments look like {- comment -}, and it looks like\ + \ you are missing the closing marker." + , D.toSimpleHint $ + "Nested multi-line comments like {- this {- and this -} -} are allowed.\ + \ The opening and closing markers must be balanced though, just\ + \ like parentheses in normal code. Maybe that is the problem?" + ] + ) + + EndOfFile_Shader -> + ( + "I got to the end of the file while parsing a GLSL block." + , + D.reflow $ + "A shader should be defined in a block like this: [glsl| ... |]" + ) + + EndOfFile_String -> + ( + "I got to the end of the file while parsing a string." + , + D.reflow $ + "Strings look like \"this\" with double quotes on each end.\ + \ Is the closing double quote missing in your code?" + ) + + EndOfFile_MultiString -> + ( + "I got to the end of the file while parsing a multi-line string." + , + D.reflow $ + "Multi-line strings look like \"\"\"this\"\"\" with three double quotes on each\ + \ end. Is the closing triple quote missing in your code?" + ) + + EndOfFile_Char -> + ( + "I got to the end of the file while parsing a character." + , + D.reflow $ + "Characters look like 'c' with single quotes on each end.\ + \ Is the closing single quote missing in your code?" + ) + + NewLineInString -> + ( + "This string is missing the closing quote." + , + D.stack + [ D.reflow $ + "Elm strings like \"this\" cannot contain newlines." + , D.toSimpleHint $ + "For strings that CAN contain newlines, say \"\"\"this\"\"\" for Elm’s\ + \ multi-line string syntax. It allows unescaped newlines and double quotes." + ] + ) + + NewLineInChar -> + ( + "This character is missing the closing quote." + , + "Elm characters must start and end with a single quote. Valid examples\n\ + \ include 'a', 'b', '\n', 'ø', and '\\u{00F8}' for unicode code points." + ) + + BadEscape _ escapeProblem -> + case escapeProblem of + UnknownEscape -> + ( + "Backslashes always start escaped characters, but I do not recognize this one:" + , D.stack + [ "Maybe there is some typo?" + , D.toSimpleHint "Valid escape characters include:" + , D.indent 4 $ D.vcat $ + [ "\\n" + , "\\r" + , "\\t" + , "\\\"" + , "\\\'" + , "\\\\" + , "\\u{03BB}" + ] + , D.reflow $ + "The last one lets encode ANY character by its Unicode code\ + \ point, so use that for anything outside the ordinary six." + ] ) - DuplicateDefinition name -> - Report.simple - "DUPLICATE DEFINITION" - ("Naming multiple values `" ++ name ++ "` in a single let-expression makes\n" - ++ "things ambiguous. When you say `" ++ name ++ "` which one do you want?" - ) - ("Find all the values named `" ++ name ++ "` in this let-expression and\n" - ++ "do some renaming. Make sure the names are distinct!" + UnicodeSyntax -> + ( + "I ran into an invalid Unicode escape character:" + , + D.stack + [ "Here are some examples of valid Unicode escape characters:" + , D.indent 4 $ D.vcat $ + [ "\\u{0041}" + , "\\u{03BB}" + , "\\u{6728}" + , "\\u{1F60A}" + ] + , D.reflow $ + "Notice that the code point is always surrounded by curly\ + \ braces. They are required!" + ] ) + UnicodeRange -> + ( + "This is not a real Unicode code point:" + , + "All valid Unicode code points are between 0 and 10FFFF." + ) --- TAGGING PARSE ERRORS - -newline :: String -newline = "NEWLINE" - -freshLine :: String -freshLine = "FRESH_LINE" - -whitespace :: String -whitespace = "WHITESPACE" - -keyword :: String -> String -keyword kwd = - "KEYWORD=" ++ kwd - -unkeyword :: String -> Maybe String -unkeyword message = - if List.isPrefixOf "KEYWORD=" message - then Just (drop (length "KEYWORD=") message) - else Nothing - - --- REPORTING PARSE ERRORS - -parseErrorReport :: [Parsec.Message] -> Report.Report -parseErrorReport messages = - let - addMsg message hint = - case message of - Parsec.SysUnExpect _msg -> - hint - - Parsec.UnExpect _msg -> - hint - - Parsec.Expect msg -> - let - msg' = - if msg `elem` [whitespace, newline, freshLine] - then "whitespace" - else msg - in - hint { _expected = Set.insert msg' (_expected hint) } - - Parsec.Message msg -> - hint { _messages = msg : _messages hint } - - (ParseHint msgs expects) = - foldr addMsg emptyHint messages - - preHint = - case msgs of - [msg] -> - case unkeyword msg of - Just kwd -> - "It looks like the keyword `" ++ kwd ++ "` is being used as a variable.\n" - ++ "Try renaming it to something else." - Nothing -> - msg + UnicodeLength numDigits badCode -> + if numDigits < 4 then + ( + "Every Unicode code point needs at least four digits:" + , + let + goodCode = replicate (4 - numDigits) '0' ++ badCode + escape = "\\u{" <> D.fromString goodCode <> "}" + in + D.hsep [ "Try", D.dullyellow escape, "instead?" ] + ) + + else + ( + "This Unicode code point has too many digits:" + , + D.fillSep + ["Valid","code","points","are","between" + , D.dullyellow "\\u{0000}", "and", D.dullyellow "\\u{10FFFF}" + ,"so","it","must","have","between","four","and","six","digits." + ] + ) + + BadChar _ -> + ( + "Ran into a bad use of single quotes." + , + D.stack + [ D.reflow $ + "If you want to create a string, switch to double quotes:" + , D.indent 4 $ + D.dullyellow "'this'" <> " => " <> D.green "\"this\"" + , D.toSimpleHint $ + "Unlike JavaScript, Elm distinguishes between strings like \"hello\"\ + \ and individual characters like 'A' and '3'. If you really do want\ + \ a character though, something went wrong and I did not find the\ + \ closing single quote." + ] + ) + + BadNumberDot numberBeforeDot -> + ( + "Numbers cannot end with a decimal points." + , + let + number = + D.fromString (show numberBeforeDot) + in + "Saying " <> D.green number <> " or " <> D.green (number <> ".0") <> " will work though!" + ) + + BadNumberEnd -> + ( + "Numbers cannot have letters or underscores in them." + , + D.reflow $ + "Maybe a space is missing between a number and a variable?" + ) + + BadNumberExp -> + ( + "If you put the letter E in a number, it should followed by more digits." + , + D.reflow $ + "If you want to say 1000, you can also say 1e3.\ + \ You cannot just end it with an E though!" + ) + + BadNumberHex -> + ( + "I see the start of a hex number, but not the end." + , + D.reflow $ + "A hex number looks like 0x123ABC, where the 0x is followed by hexidecimal\ + \ digits. Valid hexidecimal digits include: 0123456789abcdefABCDEF" + ) + + BadNumberZero -> + ( + "Normal numbers cannot start with zeros. Take the zeros off the front." + , + D.reflow $ + "Only numbers like 0x0040 or 0.25 can start with a zero." + ) + + FloatInPattern -> + ( + "I cannot pattern match with floating point numbers:" + , + D.reflow $ + "Equality on floats can be unreliable, so you usually want to check that they\ + \ are nearby with some sort of (abs (actual - expected) < 0.001) check." + ) + + BadShader msg -> + ( + "I ran into a problem while parsing this GLSL block." + , + D.reflow (Text.unpack msg) + ) + + BadUnderscore _ -> + ( + "A variable name cannot start with an underscore:" + , + D.reflow $ + "You can (1) use a wildcard like _ to ignore the value or you can (2) use\ + \ a name that starts with a letter to access the value later. Pick one!" + ) + + BadOp op stack -> + case op of + HasType -> + badOp stack "A" "\"has type\" operator" + "type annotations and record types" + "Maybe you want :: instead? Or maybe something is indented too much?" + + Equals -> + ( + D.reflow $ + "I was not expecting this equals sign" + <> contextToString " here" " while parsing " stack <> "." + , + toBadEqualsHint stack + ) - _ -> "I ran into something unexpected when parsing your code!" + Arrow -> + if isCaseRelated stack then + ( + "I ran into a stray arrow while parsing this `case` expression." + , + D.reflow $ + "All branches in a `case` must be indented the exact\ + \ same amount, so the patterns are vertically\ + \ aligned. Maybe this branch is indented too much?" + ) + + else + badOp stack "An" "arrow" + "cases expressions and anonymous functions" + "Maybe you want > or >= instead?" + + Pipe -> + badOp stack "A" "vertical bar" + "type declarations" + "Maybe you want || instead?" + + Dot -> + ( + "I was not expecting this dot." + , + D.reflow $ + "Dots are for record access and decimal points, so\ + \ they cannot float around on their own. Maybe\ + \ there is some extra whitespace?" + ) - postHint = - if Set.null expects - then "" + Theories stack allTheories -> + ( + D.reflow $ + "Something went wrong while parsing " <> contextToString "your code" "" stack <> "." + , + case Set.toList (Set.fromList allTheories) of + [] -> + D.stack + [ D.reflow $ + "I do not have any suggestions though!" + , D.reflow $ + "Can you get it down to a and share it at\ + \ ?\ + \ That way we can figure out how to give better advice!" + ] + + [theory] -> + D.reflow $ + "I was expecting to see " + <> addPeriod (theoryToString stack theory) + + theories -> + D.vcat $ + [ "I was expecting:" + , "" + ] + ++ map (bullet . theoryToString stack) theories + ) + + + +-- BAD OP HELPERS + + +badOp :: ContextStack -> String -> String -> String -> String -> ( D.Doc, D.Doc ) +badOp stack article opName setting hint = + ( + D.reflow $ + "I was not expecting this " <> opName + <> contextToString " here" " while parsing " stack <> "." + , + D.reflow $ + article <> " " <> opName <> " should only appear in " + <> setting <> ". " <> hint + ) + + +toBadEqualsHint :: ContextStack -> D.Doc +toBadEqualsHint stack = + case stack of + [] -> + D.reflow $ + "Maybe you want == instead? Or maybe something is indented too much?" + + (ExprRecord, _) : _ -> + D.reflow $ + "Records look like { x = 3, y = 4 } with the equals sign right\ + \ after the field name. Maybe you forgot a comma?" + + (Definition _, _) : rest -> + D.reflow $ + "Maybe this is supposed to be a separate definition? If so, it\ + \ is indented too far. " + <> + if any ((==) ExprLet . fst) rest then + "All definitions in a `let` expression must be vertically aligned." else - "I am looking for one of the following things:\n" - ++ concatMap ("\n "++) (Set.toList expects) - in - Report.simple "SYNTAX PROBLEM" preHint postHint + "Spaces are not allowed before top-level definitions." + + _ : rest -> + toBadEqualsHint rest -data ParseHint = ParseHint - { _messages :: [String] - , _expected :: Set.Set String - } - deriving (Show) +isCaseRelated :: ContextStack -> Bool +isCaseRelated stack = + case stack of + [] -> + False + + (context, _) : rest -> + context == ExprCase || isCaseRelated rest + + + +-- CONTEXT + + +contextToString :: String -> String -> ContextStack -> String +contextToString defaultString prefixString stack = + case stack of + [] -> + defaultString -emptyHint :: ParseHint -emptyHint = - ParseHint [] Set.empty + (context, _) : rest -> + let anchor = getAnchor rest in + prefixString <> + case context of + ExprIf -> "an `if` expression" <> anchor + ExprLet -> "a `let` expression" <> anchor + ExprFunc -> "an anonymous function" <> anchor + ExprCase -> "a `case` expression" <> anchor + ExprList -> "a list" <> anchor + ExprTuple -> "an expression (in parentheses)" <> anchor + ExprRecord -> "a record" <> anchor + Definition name -> N.toString name <> "'s definition" + Annotation name -> N.toString name <> "'s type annotation" + TypeTuple -> "a type (in parentheses)" <> anchor + TypeRecord -> "a record type" <> anchor + PatternList -> "a list pattern" <> anchor + PatternTuple -> "a pattern (in parentheses)" <> anchor + PatternRecord -> "a record pattern" <> anchor + Module -> "a module declaration" + Import -> "an import" + TypeUnion -> "a union type" + TypeAlias -> "a type alias" + Infix -> "an infix declaration" + Port -> "a port declaration" + + +getAnchor :: ContextStack -> String +getAnchor stack = + case stack of + [] -> + "" + + (context, _) : rest -> + case context of + Definition name -> + " in " <> N.toString name <> "'s definition" + + Annotation name -> + " in " <> N.toString name <> "'s type annotation" + + _ -> + getAnchor rest + + + +-- THEORY HELPERS + + +bullet :: String -> D.Doc +bullet point = + D.hang 4 (" - " <> D.fillSep (map D.fromString (words point))) + + +addPeriod :: String -> String +addPeriod msg = + if last msg `elem` ['`', ')', '.', '!', '?'] then + msg + else + msg <> "." + + +theoryToString :: ContextStack -> Theory -> String +theoryToString context theory = + case theory of + Keyword keyword -> + "the `" <> keyword <> "` keyword" + + Symbol symbol -> + case symbol of + "=" -> equalsTheory context + "->" -> "an arrow (->) followed by an expression" + ":" -> "the \"has type\" symbol (:) followed by a type" + "," -> "a comma" + "|" -> barTheory context + "::" -> "the cons operator (::) followed by more list elements" + "." -> "a dot (.)" + "-" -> "a minus sign (-)" + "_" -> "an underscore" + "(" -> "a left paren, for grouping or starting tuples" + ")" -> "a closing paren" + "[" -> "a left square bracket, for starting lists" + "]" -> "a right square bracket, to end a list" + "{" -> "a left curly brace, for starting records" + "}" -> "a right curly brace, to end a record" + "{-|" -> "a doc comment, like {-| this -}" + _ -> "the (" <> symbol <> ") symbol" + + LowVar -> + "a lower-case variable, like `x` or `user`" + + CapVar -> + "an upper-case variable, like `Maybe` or `Just`" + + InfixOp -> + "an infix operator, like (+) or (==)" + + Digit -> + "a digit from 0 to 9" + + BadSpace -> + badSpace context + + Expecting next -> + case next of + Decl -> "a declaration, like `x = 5` or `type alias Model = { ... }`" + Expr -> "an expression, like x or 42" + AfterOpExpr op -> "an expression after that (" <> N.toString op <> ") operator, like x or 42" + ElseBranch -> "an `else` branch. An `if` must handle both possibilities." + Arg -> "an argument, like `name` or `total`" + Pattern -> "a pattern, like `name` or (Just x)" + Type -> "a type, like Int or (List String)" + Listing -> "a list of exposed values and types, like (..) or (x,y,z)" + Exposing -> "something like `exposing (..)`" + + +equalsTheory :: ContextStack -> String +equalsTheory stack = + case stack of + [] -> + "an equals sign (=)" + + (context, _) : rest -> + case context of + ExprRecord -> "an equals sign (=) followed by an expression" + Definition name -> "an equals sign (=) followed by " <> N.toString name <> "'s definition" + TypeUnion -> "an equals sign (=) followed by the first union type constructor" + TypeAlias -> "an equals sign (=) followed by the aliased type" + _ -> equalsTheory rest + + +barTheory :: ContextStack -> String +barTheory stack = + case stack of + [] -> + "a vertical bar (|)" + + (context, _) : rest -> + case context of + ExprRecord -> "a vertical bar (|) followed by the record fields you want to update" + TypeRecord -> "a vertical bar (|) followed by some record field types" + TypeUnion -> "a vertical bar (|) followed by more union type constructors" + _ -> barTheory rest + + +badSpace :: ContextStack -> String +badSpace stack = + case stack of + [] -> + "more indentation? I was not done with that last thing yet." + + (context, _) : rest -> + case context of + ExprIf -> "the end of that `if`" <> badSpaceExprEnd rest + ExprLet -> "the end of that `let`" <> badSpaceExprEnd rest + ExprFunc -> badSpace rest + ExprCase -> "more of that `case`" <> badSpaceExprEnd rest + ExprList -> "the end of that list" <> badSpaceExprEnd rest + ExprTuple -> "a closing paren" <> badSpaceExprEnd rest + ExprRecord -> "the end of that record" <> badSpaceExprEnd rest + Definition name -> "the rest of " <> N.toString name <> "'s definition" <> badSpaceExprEnd stack + Annotation name -> "the rest of " <> N.toString name <> "'s type annotation" <> badSpaceEnd + TypeTuple -> "a closing paren" <> badSpaceEnd + TypeRecord -> "the end of that record" <> badSpaceEnd + PatternList -> "the end of that list" <> badSpaceEnd + PatternTuple -> "a closing paren" <> badSpaceEnd + PatternRecord -> "the end of that record" <> badSpaceEnd + Module -> "something like `module Main exposing (..)`" + Import -> "something like `import Html exposing (..)`" + TypeUnion -> "more of that union type" <> badSpaceEnd + TypeAlias -> "more of that type alias" <> badSpaceEnd + Infix -> "more of that infix declaration" <> badSpaceEnd + Port -> "more of that port declaration" <> badSpaceEnd + + +badSpaceEnd :: String +badSpaceEnd = + ". Maybe you forgot some code? Or you need more indentation?" + + +badSpaceExprEnd :: ContextStack -> String +badSpaceExprEnd stack = + case stack of + [] -> + badSpaceEnd + + (Definition name, R.Position _ column) : _ -> + let + ending = + if column <= 1 then + "to be indented?" + else + "more indentation? (Try " <> show (column + 1) <> "+ spaces.)" + in + ". Maybe you forgot some code? Or maybe the body of `" + <> N.toString name + <> "` needs " <> ending + + _ : rest -> + badSpaceExprEnd rest diff --git a/parser/src/Reporting/Region.hs b/parser/src/Reporting/Region.hs deleted file mode 100644 index d2cee4857..000000000 --- a/parser/src/Reporting/Region.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reporting.Region where - -import qualified Text.Parsec.Pos as Parsec - - -data Region = Region - { start :: Position - , end :: Position - } - deriving (Eq, Show) - - -data Position = Position - { line :: Int - , column :: Int - } - deriving (Eq, Show) - - -fromSourcePos :: Parsec.SourcePos -> Position -fromSourcePos sourcePos = - Position - (Parsec.sourceLine sourcePos) - (Parsec.sourceColumn sourcePos) - - -merge :: Region -> Region -> Region -merge (Region start _) (Region _ end) = - Region start end - - --- TO STRING - -toString :: Region -> String -toString (Region start end) = - case line start == line end of - False -> - "between lines " ++ show (line start) - ++ " and " ++ show (line end) - - True -> - "on line " ++ show (line end) ++ ", column " - ++ show (column start) ++ " to " ++ show (column end) diff --git a/parser/src/Reporting/Render/Code.hs b/parser/src/Reporting/Render/Code.hs new file mode 100644 index 000000000..c1543b72d --- /dev/null +++ b/parser/src/Reporting/Render/Code.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE OverloadedStrings #-} +module Reporting.Render.Code + ( Source + , toSource + , render + , CodePair(..) + , renderPair + ) + where + + +import qualified Data.List as List +import qualified Data.Text as Text +import Data.Word (Word16) + +import Reporting.Doc (Doc, (<>)) +import qualified Reporting.Doc as D +import qualified Reporting.Annotation as A + + + +-- CODE + + +newtype Source = + Source [(Int, Text.Text)] + + +toSource :: Text.Text -> Source +toSource source = + Source $ zip [1..] $ + Text.lines source ++ [Text.empty] + + + +-- RENDER + + +(|>) :: a -> (a -> b) -> b +(|>) a f = + f a + + +render :: Source -> A.Region -> Maybe A.Region -> Doc +render (Source sourceLines) region@(A.Region (A.Position startLine _) (A.Position endLine _)) maybeSubRegion = + let + relevantLines = + sourceLines + |> drop (fromIntegral (startLine - 1)) + |> take (fromIntegral (1 + endLine - startLine)) + + width = + length (show (fst (last relevantLines))) + + smallerRegion = + maybe region id maybeSubRegion + in + case makeUnderline width endLine smallerRegion of + Nothing -> + drawLines True width smallerRegion relevantLines D.empty + + Just underline -> + drawLines False width smallerRegion relevantLines underline + +makeUnderline :: Int -> Word16 -> A.Region -> Maybe Doc +makeUnderline width realEndLine (A.Region (A.Position start c1) (A.Position end c2)) = + if start /= end || end < realEndLine then + Nothing + + else + let + spaces = replicate (fromIntegral c1 + width + 1) ' ' + zigzag = replicate (max 1 (fromIntegral (c2 - c1))) '^' + in + Just (D.fromChars spaces <> D.dullred (D.fromChars zigzag)) + + +drawLines :: Bool -> Int -> A.Region -> [(Word16, String)] -> Doc -> Doc +drawLines addZigZag width (A.Region (A.Position startLine _) (A.Position endLine _)) sourceLines finalLine = + D.vcat $ + map (drawLine addZigZag width startLine endLine) sourceLines + ++ [finalLine] + + +drawLine :: Bool -> Int -> Word16 -> Word16 -> (Word16, String) -> Doc +drawLine addZigZag width startLine endLine (n, line) = + addLineNumber addZigZag width startLine endLine n (D.fromChars line) + + +addLineNumber :: Bool -> Int -> Word16 -> Word16 -> Word16 -> Doc -> Doc +addLineNumber addZigZag width start end n line = + let + number = + show n + + lineNumber = + replicate (width - length number) ' ' ++ number ++ "|" + + spacer = + if addZigZag && start <= n && n <= end then + D.dullred ">" + else + " " + in + D.fromChars lineNumber <> spacer <> line + + + +-- RENDER PAIR + + +data CodePair + = OneLine Doc + | TwoChunks Doc Doc + + +renderPair :: Source -> A.Region -> A.Region -> CodePair +renderPair source@(Source sourceLines) region1 region2 = + let + (A.Region (A.Position startRow1 startCol1) (A.Position endRow1 endCol1)) = region1 + (A.Region (A.Position startRow2 startCol2) (A.Position endRow2 endCol2)) = region2 + in + if startRow1 == endRow1 && endRow1 == startRow2 && startRow2 == endRow2 then + let + lineNumber = show startRow1 + spaces1 = replicate (fromIntegral startCol1 + length lineNumber + 1) ' ' + zigzag1 = replicate (fromIntegral (endCol1 - startCol1)) '^' + spaces2 = replicate (fromIntegral (startCol2 - endCol1)) ' ' + zigzag2 = replicate (fromIntegral (endCol2 - startCol2)) '^' + + (Just line) = List.lookup startRow1 sourceLines + in + OneLine $ + D.vcat + [ D.fromChars lineNumber <> "| " <> D.fromChars line + , D.fromChars spaces1 <> D.dullred (D.fromChars zigzag1) <> + D.fromChars spaces2 <> D.dullred (D.fromChars zigzag2) + ] + + else + TwoChunks + (render source region1 Nothing) + (render source region2 Nothing) diff --git a/parser/src/Reporting/Report.hs b/parser/src/Reporting/Report.hs index 5724bcfe8..a35e296ba 100644 --- a/parser/src/Reporting/Report.hs +++ b/parser/src/Reporting/Report.hs @@ -1,230 +1,85 @@ -{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE OverloadedStrings #-} module Reporting.Report - ( Report(Report) - , simple - , toString - , printError, printWarning - ) where - -import Control.Applicative ((<|>)) -import Control.Monad.Writer (Writer, execWriter, tell) -import qualified Data.List.Split as Split -import System.Console.ANSI -import ElmFormat.World + ( Report(..) + , toDoc + , toCodeSnippet + , toCodePair + ) + where -import qualified Reporting.Region as R - - -data Report = Report - { _title :: String - , _highlight :: Maybe R.Region - , _preHint :: String - , _postHint :: String - } - deriving (Show) - - -simple :: String -> String -> String -> Report -simple title pre post = - Report title Nothing pre post - - -toString :: String -> R.Region -> Report -> String -> String -toString location region report source = - execWriter (render plain location region report source) - -printError :: World m => String -> R.Region -> Report -> String -> m () -printError location region report source = - render (ansi Error) location region report source - - -printWarning :: World m => String -> R.Region -> Report -> String -> m () -printWarning location region report source = - render (ansi Warning) location region report source +import qualified Reporting.Doc as D +import qualified Reporting.Region as R +import qualified Reporting.Render.Code as Code -render - :: (Monad m) - => Renderer m - -> String - -> R.Region - -> Report - -> String - -> m () -render renderer location region (Report title highlight pre post) source = - do messageBar renderer title location - normal renderer (pre ++ "\n\n") - grabRegion renderer highlight region source - normal renderer ("\n" ++ if null post then "\n" else post ++ "\n\n\n") +-- BUILD REPORTS --- RENDERING -data Renderer m = Renderer - { normal :: String -> m () - , header :: String -> m () - , accent :: String -> m () +data Report = + Report + { _title :: String + , _region :: R.Region + , _sgstns :: [String] + , _message :: D.Doc } -plain :: Renderer (Writer String) -plain = - Renderer tell tell tell - - -data Type = Error | Warning - - -ansi :: World m => Type -> Renderer m -ansi tipe = - let - put = - putStrStderr - - put' intensity color string = - do putSgrStderr [SetColor Foreground intensity color] - put string - putSgrStderr [Reset] - - accentColor = - case tipe of - Error -> Red - Warning -> Yellow - in - Renderer - put - (put' Dull Cyan) - (put' Dull accentColor) - - - - --- REPORT HEADER - -messageBar :: Renderer m -> String -> String -> m () -messageBar renderer tag location = - let - usedSpace = 4 + length tag + 1 + length location - in - header renderer $ - "-- " ++ tag ++ " " - ++ replicate (max 1 (80 - usedSpace)) '-' - ++ " " ++ location ++ "\n\n" - - --- REGIONS - -grabRegion - :: (Monad m) - => Renderer m - -> Maybe R.Region - -> R.Region - -> String - -> m () -grabRegion renderer maybeSubRegion region@(R.Region start end) source = - let - (R.Position startLine startColumn) = start - (R.Position endLine endColumn) = end +toDoc :: FilePath -> Report -> D.Doc +toDoc filePath (Report title _ _ message) = + D.vcat + [ messageBar title filePath + , "" + , message + , "" + ] - (|>) = flip ($) - relevantLines = - -- Using `lines` here will strip the last line. - Split.splitOn "\n" source - |> drop (startLine - 1) - |> take (endLine - startLine + 1) - in - case relevantLines of - [] -> - normal renderer "" - - [sourceLine] -> - singleLineRegion renderer startLine sourceLine $ - case maybeSubRegion of - Nothing -> - (0, startColumn, endColumn, length sourceLine) - - Just (R.Region s e) -> - (startColumn, R.column s, R.column e, endColumn) - - firstLine : rest -> - let - filteredFirstLine = - replicate (startColumn - 1) ' ' - ++ drop (startColumn - 1) firstLine - - filteredLastLine = - take (endColumn) (last rest) - - focusedRelevantLines = - filteredFirstLine : init rest ++ [filteredLastLine] - - lineNumbersWidth = - length (show endLine) - - subregion = - maybeSubRegion <|> Just region - - numberedLines = - zipWith - (addLineNumber renderer subregion lineNumbersWidth) - [startLine .. endLine] - focusedRelevantLines - in - mapM_ (\line -> line >> normal renderer "\n") numberedLines - - -addLineNumber - :: (Monad m) - => Renderer m - -> Maybe R.Region - -> Int - -> Int - -> String - -> m () -addLineNumber renderer maybeSubRegion width n line = +messageBar :: String -> FilePath -> D.Doc +messageBar title filePath = let - number = - if n < 0 then " " else show n - - lineNumber = - replicate (width - length number) ' ' ++ number ++ "│" - - spacer (R.Region start end) = - if R.line start <= n && n <= R.line end - then accent renderer ">" - else normal renderer " " - in - do normal renderer lineNumber - maybe (normal renderer " ") spacer maybeSubRegion - normal renderer line - - -singleLineRegion - :: (Monad m) - => Renderer m - -> Int - -> String - -> (Int, Int, Int, Int) - -> m () -singleLineRegion renderer lineNum sourceLine (start, innerStart, innerEnd, end) = - let - width = - length (show lineNum) - - underline = - replicate (innerStart + width + 1) ' ' - ++ replicate (max 1 (innerEnd - innerStart)) '^' - - (|>) = flip ($) - - trimmedSourceLine = - sourceLine - |> drop (start - 1) - |> take (end - start + 1) - |> (++) (replicate (start - 1) ' ') + usedSpace = + 4 + length title + 1 + length filePath in - do addLineNumber renderer Nothing width lineNum trimmedSourceLine - accent renderer $ "\n" ++ underline + D.dullcyan $ D.fromString $ + "-- " ++ title + ++ " " ++ replicate (max 1 (80 - usedSpace)) '-' + ++ " " ++ filePath + + + +-- CODE FORMATTING + + +toCodeSnippet :: Code.Source -> R.Region -> Maybe R.Region -> (D.Doc, D.Doc) -> D.Doc +toCodeSnippet source region highlight (preHint, postHint) = + D.vcat + [ preHint + , "" + , Code.render source region highlight + , postHint + ] + + +toCodePair :: Code.Source -> R.Region -> R.Region -> (D.Doc, D.Doc) -> (D.Doc, D.Doc, D.Doc) -> D.Doc +toCodePair source r1 r2 (oneStart, oneEnd) (twoStart, twoMiddle, twoEnd) = + case Code.renderPair source r1 r2 of + Code.OneLine codeDocs -> + D.vcat + [ oneStart + , "" + , codeDocs + , oneEnd + ] + + Code.TwoChunks code1 code2 -> + D.vcat + [ twoStart + , "" + , code1 + , twoMiddle + , "" + , code2 + , twoEnd + ] diff --git a/parser/src/Reporting/Result.hs b/parser/src/Reporting/Result.hs index fd7597d22..664184eeb 100644 --- a/parser/src/Reporting/Result.hs +++ b/parser/src/Reporting/Result.hs @@ -46,7 +46,7 @@ from f except = ok answer Left errors -> - throwMany (map (A.map f) errors) + throwMany (map (fmap f) errors) mapError :: (e -> e') -> Result w e a -> Result w e' a @@ -57,7 +57,7 @@ mapError f (Result warnings rawResult) = Ok v Err msgs -> - Err (map (A.map f) msgs) + Err (map (fmap f) msgs) warn :: R.Region -> w -> Result w e () diff --git a/src/AST/MapExpr.hs b/src/AST/MapExpr.hs index 543017aea..8170f7306 100644 --- a/src/AST/MapExpr.hs +++ b/src/AST/MapExpr.hs @@ -13,7 +13,7 @@ class MapExpr a where instance MapExpr (Located Expr') where - mapExpr f (A region a) = A region (f a) + mapExpr f (At region a) = At region (f a) instance MapExpr IfClause where diff --git a/src/AST/MapNamespace.hs b/src/AST/MapNamespace.hs index 40e6df179..9ec2b1365 100644 --- a/src/AST/MapNamespace.hs +++ b/src/AST/MapNamespace.hs @@ -56,4 +56,4 @@ instance MapNamespace a => MapNamespace (TopLevelStructure a) where _ -> struct instance MapNamespace a => MapNamespace (Located a) where - mapNamespace f (A region a) = A region (mapNamespace f a) + mapNamespace f (At region a) = At region (mapNamespace f a) diff --git a/src/CommandLine/Helpers.hs b/src/CommandLine/Helpers.hs index d97f8a279..6932e858c 100644 --- a/src/CommandLine/Helpers.hs +++ b/src/CommandLine/Helpers.hs @@ -9,6 +9,7 @@ import ElmFormat.World import qualified Reporting.Annotation as RA import qualified Reporting.Report as Report import qualified Reporting.Error.Syntax as Syntax +import qualified Reporting.Doc as Doc r :: ErrorMessage -> String @@ -23,4 +24,4 @@ showErrors filename source errs = do printError :: World m => String -> String -> RA.Located Syntax.Error -> m () printError filename source (RA.A range err) = - Report.printError filename range (Syntax.toReport err) source + Doc.toAnsi $ Report.toDoc filename range (Syntax.toReport err) source diff --git a/stack.yaml b/stack.yaml index a2394c8bc..35e6064d0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,8 +41,6 @@ packages: # Dependency packages to be pulled from upstream that are not in the resolver # (e.g., acme-missiles-0.3) extra-deps: -- indents-0.3.3 -- concatenative-1.0.1 # required by indents-0.3.3 - binary-0.8.7.0 # lts-13.25 only has 0.8.6.0 # Override default flag values for local packages and extra-deps