diff --git a/compiler/src/AST/Source.hs b/compiler/src/AST/Source.hs index 38afdc018..5af9dc98d 100644 --- a/compiler/src/AST/Source.hs +++ b/compiler/src/AST/Source.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE EmptyDataDecls #-} {-# OPTIONS_GHC -Wall #-} module AST.Source - ( Expr, + ( Comment (..), + GREN_COMMENT, + Expr, Expr_ (..), VarType (..), Def (..), @@ -23,7 +26,7 @@ module AST.Source Effects (..), Manager (..), Docs (..), - Comment (..), + DocComment (..), Exposing (..), Exposed (..), Privacy (..), @@ -33,11 +36,20 @@ where import qualified AST.Utils.Binop as Binop import Data.Name (Name) import qualified Data.Name as Name +import qualified Data.Utf8 as Utf8 import qualified Gren.Float as EF import qualified Gren.String as ES import qualified Parse.Primitives as P import qualified Reporting.Annotation as A +-- COMMENTS + +data Comment + = BlockComment (Utf8.Utf8 GREN_COMMENT) + | LineComment (Utf8.Utf8 GREN_COMMENT) + +data GREN_COMMENT + -- EXPRESSIONS type Expr = A.Located Expr_ @@ -157,10 +169,10 @@ data Manager data Docs = NoDocs A.Region - | YesDocs Comment [(Name, Comment)] + | YesDocs DocComment [(Name, DocComment)] -newtype Comment - = Comment P.Snippet +newtype DocComment + = DocComment P.Snippet -- EXPOSING diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index e6e80e2f9..45cba8018 100644 --- a/compiler/src/Compile.hs +++ b/compiler/src/Compile.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} - module Compile ( Artifacts (..), compile, diff --git a/compiler/src/Gren/Docs.hs b/compiler/src/Gren/Docs.hs index 9dbf10f87..f6d0526d0 100644 --- a/compiler/src/Gren/Docs.hs +++ b/compiler/src/Gren/Docs.hs @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wall #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} module Gren.Docs ( Documentation, @@ -270,8 +272,8 @@ fromModule modul@(Can.Module _ exports docs _ _ _ _ _) = -- PARSE OVERVIEW -parseOverview :: Src.Comment -> Either E.Error [A.Located Name.Name] -parseOverview (Src.Comment snippet) = +parseOverview :: Src.DocComment -> Either E.Error [A.Located Name.Name] +parseOverview (Src.DocComment snippet) = case P.fromSnippet (chompOverview []) E.BadEnd snippet of Left err -> Left (E.SyntaxProblem err) @@ -394,7 +396,7 @@ onlyInExports name (A.At region _) = -- CHECK DEFS -checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.Comment -> Map.Map Name.Name Src.Comment -> Can.Module -> Either E.Error Module +checkDefs :: Map.Map Name.Name (A.Located Can.Export) -> Src.DocComment -> Map.Map Name.Name Src.DocComment -> Can.Module -> Either E.Error Module checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases infixes effects) = let types = gatherTypes decls Map.empty info = Info comments types unions aliases infixes effects @@ -402,12 +404,12 @@ checkDefs exportDict overview comments (Can.Module name _ _ decls unions aliases (_, Left problems) -> Left $ E.DefProblems (OneOrMore.destruct NE.List problems) (_, Right inserters) -> Right $ foldr ($) (emptyModule name overview) inserters -emptyModule :: ModuleName.Canonical -> Src.Comment -> Module -emptyModule (ModuleName.Canonical _ name) (Src.Comment overview) = +emptyModule :: ModuleName.Canonical -> Src.DocComment -> Module +emptyModule (ModuleName.Canonical _ name) (Src.DocComment overview) = Module name (Json.fromComment overview) Map.empty Map.empty Map.empty Map.empty data Info = Info - { _iComments :: Map.Map Name.Name Src.Comment, + { _iComments :: Map.Map Name.Name Src.DocComment, _iValues :: Map.Map Name.Name (Either A.Region Can.Type), _iUnions :: Map.Map Name.Name Can.Union, _iAliases :: Map.Map Name.Name Can.Alias, @@ -461,7 +463,7 @@ getComment region name info = case Map.lookup name (_iComments info) of Nothing -> Result.throw (E.NoComment name region) - Just (Src.Comment snippet) -> + Just (Src.DocComment snippet) -> Result.ok (Json.fromComment snippet) getType :: Name.Name -> Info -> Result.Result i w E.DefProblem Type.Type diff --git a/compiler/src/Gren/Kernel.hs b/compiler/src/Gren/Kernel.hs index bc44163f5..77e60df46 100644 --- a/compiler/src/Gren/Kernel.hs +++ b/compiler/src/Gren/Kernel.hs @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wall #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} module Gren.Kernel ( Content (..), diff --git a/compiler/src/Json/Decode.hs b/compiler/src/Json/Decode.hs index 292948e51..cb88fa393 100644 --- a/compiler/src/Json/Decode.hs +++ b/compiler/src/Json/Decode.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Json.Decode ( fromByteString, diff --git a/compiler/src/Parse/Declaration.hs b/compiler/src/Parse/Declaration.hs index c379d9d28..0a63eba73 100644 --- a/compiler/src/Parse/Declaration.hs +++ b/compiler/src/Parse/Declaration.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} module Parse.Declaration ( Decl (..), @@ -27,10 +28,10 @@ import qualified Reporting.Error.Syntax as E -- DECLARATION data Decl - = Value (Maybe Src.Comment) (A.Located Src.Value) - | Union (Maybe Src.Comment) (A.Located Src.Union) - | Alias (Maybe Src.Comment) (A.Located Src.Alias) - | Port (Maybe Src.Comment) Src.Port + = Value (Maybe Src.DocComment) (A.Located Src.Value) + | Union (Maybe Src.DocComment) (A.Located Src.Union) + | Alias (Maybe Src.DocComment) (A.Located Src.Alias) + | Port (Maybe Src.DocComment) Src.Port declaration :: Space.Parser E.Decl Decl declaration = @@ -46,7 +47,7 @@ declaration = -- DOC COMMENT -chompDocComment :: Parser E.Decl (Maybe Src.Comment) +chompDocComment :: Parser E.Decl (Maybe Src.DocComment) chompDocComment = oneOfWithFallback [ do @@ -59,7 +60,7 @@ chompDocComment = -- DEFINITION and ANNOTATION -valueDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl +valueDecl :: Maybe Src.DocComment -> A.Position -> Space.Parser E.Decl Decl valueDecl maybeDocs start = do name <- Var.lower E.DeclStart @@ -80,7 +81,7 @@ valueDecl maybeDocs start = chompDefArgsAndBody maybeDocs start (A.at start end name) Nothing [] ] -chompDefArgsAndBody :: Maybe Src.Comment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl +chompDefArgsAndBody :: Maybe Src.DocComment -> A.Position -> A.Located Name.Name -> Maybe Src.Type -> [Src.Pattern] -> Space.Parser E.DeclDef Decl chompDefArgsAndBody maybeDocs start name tipe revArgs = oneOf E.DeclDefEquals @@ -114,7 +115,7 @@ chompMatchingName expectedName = -- TYPE DECLARATIONS -typeDecl :: Maybe Src.Comment -> A.Position -> Space.Parser E.Decl Decl +typeDecl :: Maybe Src.DocComment -> A.Position -> Space.Parser E.Decl Decl typeDecl maybeDocs start = inContext E.DeclType (Keyword.type_ E.DeclStart) $ do @@ -197,7 +198,7 @@ chompVariants variants end = -- PORT -portDecl :: Maybe Src.Comment -> Space.Parser E.Decl Decl +portDecl :: Maybe Src.DocComment -> Space.Parser E.Decl Decl portDecl maybeDocs = inContext E.Port (Keyword.port_ E.DeclStart) $ do diff --git a/compiler/src/Parse/Expression.hs b/compiler/src/Parse/Expression.hs index 98a36c4aa..dedec1ff7 100644 --- a/compiler/src/Parse/Expression.hs +++ b/compiler/src/Parse/Expression.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} module Parse.Expression ( expression, diff --git a/compiler/src/Parse/Module.hs b/compiler/src/Parse/Module.hs index 86b08c3a5..f7474c194 100644 --- a/compiler/src/Parse/Module.hs +++ b/compiler/src/Parse/Module.hs @@ -1,5 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} +{-# OPTIONS_GHC -Wno-error=unused-matches #-} module Parse.Module ( fromByteString, @@ -125,7 +128,7 @@ categorizeDecls values unions aliases ports decls = -- TO DOCS -toDocs :: Either A.Region Src.Comment -> [Decl.Decl] -> Src.Docs +toDocs :: Either A.Region Src.DocComment -> [Decl.Decl] -> Src.Docs toDocs comment decls = case comment of Right overview -> @@ -133,7 +136,7 @@ toDocs comment decls = Left region -> Src.NoDocs region -getComments :: [Decl.Decl] -> [(Name.Name, Src.Comment)] -> [(Name.Name, Src.Comment)] +getComments :: [Decl.Decl] -> [(Name.Name, Src.DocComment)] -> [(Name.Name, Src.DocComment)] getComments decls comments = case decls of [] -> @@ -145,7 +148,7 @@ getComments decls comments = Decl.Alias c (A.At _ (Src.Alias n _ _)) -> getComments otherDecls (addComment c n comments) Decl.Port c (Src.Port n _) -> getComments otherDecls (addComment c n comments) -addComment :: Maybe Src.Comment -> A.Located Name.Name -> [(Name.Name, Src.Comment)] -> [(Name.Name, Src.Comment)] +addComment :: Maybe Src.DocComment -> A.Located Name.Name -> [(Name.Name, Src.DocComment)] -> [(Name.Name, Src.DocComment)] addComment maybeComment (A.At _ name) comments = case maybeComment of Just comment -> (name, comment) : comments @@ -153,11 +156,12 @@ addComment maybeComment (A.At _ name) comments = -- FRESH LINES -freshLine :: (Row -> Col -> E.Module) -> Parser E.Module () +freshLine :: (Row -> Col -> E.Module) -> Parser E.Module [Src.Comment] freshLine toFreshLineError = do - Space.chomp E.ModuleSpace + comments <- Space.chomp E.ModuleSpace Space.checkFreshLine toFreshLineError + return comments -- CHOMP DECLARATIONS @@ -183,10 +187,10 @@ chompInfixes infixes = -- MODULE DOC COMMENT -chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.Comment) +chompModuleDocCommentSpace :: Parser E.Module (Either A.Region Src.DocComment) chompModuleDocCommentSpace = do - (A.At region ()) <- addLocation (freshLine E.FreshLine) + (A.At region comments) <- addLocation (freshLine E.FreshLine) oneOfWithFallback [ do docComment <- Space.docComment E.ImportStart E.ModuleSpace @@ -199,7 +203,7 @@ chompModuleDocCommentSpace = -- HEADER data Header - = Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.Comment) + = Header (A.Located Name.Name) Effects (A.Located Src.Exposing) (Either A.Region Src.DocComment) data Effects = NoEffects A.Region @@ -329,7 +333,7 @@ chompSubscription = spaces_em addLocation (Var.upper E.Effect) -spaces_em :: Parser E.Module () +spaces_em :: Parser E.Module [Src.Comment] spaces_em = Space.chompAndCheckIndent E.ModuleSpace E.Effect diff --git a/compiler/src/Parse/Pattern.hs b/compiler/src/Parse/Pattern.hs index 51af8ac35..9f77df62b 100644 --- a/compiler/src/Parse/Pattern.hs +++ b/compiler/src/Parse/Pattern.hs @@ -1,7 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} module Parse.Pattern ( term, diff --git a/compiler/src/Parse/Primitives.hs b/compiler/src/Parse/Primitives.hs index 7d70178b9..2238dc3e5 100644 --- a/compiler/src/Parse/Primitives.hs +++ b/compiler/src/Parse/Primitives.hs @@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Parse.Primitives ( fromByteString, diff --git a/compiler/src/Parse/Space.hs b/compiler/src/Parse/Space.hs index e4e452880..06b4a0ebb 100644 --- a/compiler/src/Parse/Space.hs +++ b/compiler/src/Parse/Space.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} module Parse.Space ( Parser, @@ -18,6 +17,7 @@ module Parse.Space where import qualified AST.Source as Src +import qualified Data.Utf8 as Utf8 import Data.Word (Word16, Word8) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (Ptr, minusPtr, plusPtr) @@ -33,14 +33,14 @@ type Parser x a = -- CHOMP -chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x () +chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x [Src.Comment] chomp toError = P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let (# status, newPos, newRow, newCol #) = eatSpaces pos end row col + let (# status, newPos, newRow, newCol #) = eatSpaces pos end row col [] in case status of - Good -> + Good comments -> let !newState = P.State src newPos end indent newRow newCol - in cok () newState + in cok comments newState HasTab -> cerr newRow newCol (toError E.HasTab) EndlessMultiComment -> cerr newRow newCol (toError E.EndlessMultiComment) @@ -69,16 +69,16 @@ checkFreshLine toError = -- CHOMP AND CHECK -chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x () +chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x [Src.Comment] chompAndCheckIndent toSpaceError toIndentError = P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ -> - let (# status, newPos, newRow, newCol #) = eatSpaces pos end row col + let (# status, newPos, newRow, newCol #) = eatSpaces pos end row col [] in case status of - Good -> + Good comments -> if newCol > indent && newCol > 1 then let !newState = P.State src newPos end indent newRow newCol - in cok () newState + in cok comments newState else cerr row col toIndentError HasTab -> cerr newRow newCol (toSpaceError E.HasTab) EndlessMultiComment -> cerr newRow newCol (toSpaceError E.EndlessMultiComment) @@ -86,82 +86,90 @@ chompAndCheckIndent toSpaceError toIndentError = -- EAT SPACES data Status - = Good + = Good [Src.Comment] | HasTab | EndlessMultiComment -eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatSpaces pos end row col = +eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Src.Comment] -> (# Status, Ptr Word8, Row, Col #) +eatSpaces pos end row col comments = if pos >= end - then (# Good, pos, row, col #) + then (# Good (reverse comments), pos, row, col #) else case P.unsafeIndex pos of 0x20 {- -} -> - eatSpaces (plusPtr pos 1) end row (col + 1) + eatSpaces (plusPtr pos 1) end row (col + 1) comments 0x0A {- \n -} -> - eatSpaces (plusPtr pos 1) end (row + 1) 1 + eatSpaces (plusPtr pos 1) end (row + 1) 1 comments 0x7B {- { -} -> - eatMultiComment pos end row col + eatMultiComment pos end row col comments 0x2D {- - -} -> let !pos1 = plusPtr pos 1 in if pos1 < end && P.unsafeIndex pos1 == 0x2D {- - -} - then eatLineComment (plusPtr pos 2) end row (col + 2) - else (# Good, pos, row, col #) + then + let !start = plusPtr pos 2 + in eatLineComment start start end row (col + 2) comments + else (# Good (reverse comments), pos, row, col #) 0x0D {- \r -} -> - eatSpaces (plusPtr pos 1) end row col + eatSpaces (plusPtr pos 1) end row col comments 0x09 {- \t -} -> (# HasTab, pos, row, col #) _ -> - (# Good, pos, row, col #) + (# Good (reverse comments), pos, row, col #) -- LINE COMMENTS -eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatLineComment pos end row col = +eatLineComment :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Src.Comment] -> (# Status, Ptr Word8, Row, Col #) +eatLineComment start pos end row col comments = if pos >= end - then (# Good, pos, row, col #) + then + let !comment = Utf8.fromPtr start end + !finalComments = Src.LineComment comment : comments + in (# Good (reverse finalComments), pos, row, col #) else let !word = P.unsafeIndex pos in if word == 0x0A {- \n -} - then eatSpaces (plusPtr pos 1) end (row + 1) 1 + then + let !comment = Utf8.fromPtr start pos + !newComments = Src.LineComment comment : comments + in eatSpaces (plusPtr pos 1) end (row + 1) 1 newComments else let !newPos = plusPtr pos (P.getCharWidth word) - in eatLineComment newPos end row (col + 1) + in eatLineComment start newPos end row (col + 1) comments -- MULTI COMMENTS -eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #) -eatMultiComment pos end row col = +eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> [Src.Comment] -> (# Status, Ptr Word8, Row, Col #) +eatMultiComment pos end row col comments = let !pos1 = plusPtr pos 1 !pos2 = plusPtr pos 2 in if pos2 >= end - then (# Good, pos, row, col #) + then (# Good (reverse comments), pos, row, col #) else if P.unsafeIndex pos1 == 0x2D {- - -} then if P.unsafeIndex pos2 == 0x7C - then (# Good, pos, row, col #) + then (# Good (reverse comments), pos, row, col #) else let (# status, newPos, newRow, newCol #) = - eatMultiCommentHelp pos2 end row (col + 2) 1 + eatMultiCommentHelp pos2 pos2 end row (col + 2) 1 in case status of - MultiGood -> eatSpaces newPos end newRow newCol + MultiGood comment -> eatSpaces newPos end newRow newCol (Src.BlockComment comment : comments) MultiTab -> (# HasTab, newPos, newRow, newCol #) MultiEndless -> (# EndlessMultiComment, pos, row, col #) - else (# Good, pos, row, col #) + else (# Good (reverse comments), pos, row, col #) data MultiStatus - = MultiGood + = MultiGood !(Utf8.Utf8 Src.GREN_COMMENT) | MultiTab | MultiEndless -eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #) -eatMultiCommentHelp pos end row col openComments = +eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #) +eatMultiCommentHelp start pos end row col openComments = if pos >= end then (# MultiEndless, pos, row, col #) else let !word = P.unsafeIndex pos in if word == 0x0A {- \n -} - then eatMultiCommentHelp (plusPtr pos 1) end (row + 1) 1 openComments + then eatMultiCommentHelp start (plusPtr pos 1) end (row + 1) 1 openComments else if word == 0x09 {- \t -} then (# MultiTab, pos, row, col #) @@ -169,18 +177,20 @@ eatMultiCommentHelp pos end row col openComments = if word == 0x2D {- - -} && P.isWord (plusPtr pos 1) end 0x7D {- } -} then if openComments == 1 - then (# MultiGood, plusPtr pos 2, row, col + 2 #) - else eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments - 1) + then + let !comment = Utf8.fromPtr start pos + in (# MultiGood comment, plusPtr pos 2, row, col + 2 #) + else eatMultiCommentHelp start (plusPtr pos 2) end row (col + 2) (openComments - 1) else if word == 0x7B {- { -} && P.isWord (plusPtr pos 1) end 0x2D {- - -} - then eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1) + then eatMultiCommentHelp start (plusPtr pos 2) end row (col + 2) (openComments + 1) else let !newPos = plusPtr pos (P.getCharWidth word) - in eatMultiCommentHelp newPos end row (col + 1) openComments + in eatMultiCommentHelp start newPos end row (col + 1) openComments -- DOCUMENTATION COMMENT -docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment +docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.DocComment docComment toExpectation toSpaceError = P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> let !pos3 = plusPtr pos 3 @@ -192,13 +202,13 @@ docComment toExpectation toSpaceError = let !col3 = col + 3 (# status, newPos, newRow, newCol #) = - eatMultiCommentHelp pos3 end row col3 1 + eatMultiCommentHelp pos3 pos3 end row col3 1 in case status of - MultiGood -> + MultiGood _ -> let !off = minusPtr pos3 (unsafeForeignPtrToPtr src) !len = minusPtr newPos pos3 - 2 !snippet = P.Snippet src off len row col3 - !comment = Src.Comment snippet + !comment = Src.DocComment snippet !newState = P.State src newPos end indent newRow newCol in cok comment newState MultiTab -> cerr newRow newCol (toSpaceError E.HasTab) diff --git a/compiler/src/Parse/String.hs b/compiler/src/Parse/String.hs index 8fad4c018..f0f2fa844 100644 --- a/compiler/src/Parse/String.hs +++ b/compiler/src/Parse/String.hs @@ -2,7 +2,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} module Parse.String ( string, diff --git a/compiler/src/Parse/Type.hs b/compiler/src/Parse/Type.hs index b77e10cc8..1e95aa9b8 100644 --- a/compiler/src/Parse/Type.hs +++ b/compiler/src/Parse/Type.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +-- Temporary while implementing gren format +{-# OPTIONS_GHC -Wno-error=unused-do-bind #-} module Parse.Type ( expression, diff --git a/gren.cabal b/gren.cabal index e28500e0e..c77b97cb0 100644 --- a/gren.cabal +++ b/gren.cabal @@ -37,7 +37,7 @@ Common gren-common if flag(dev) ghc-options: -O0 -Wall -Werror else - ghc-options: -O2 -threaded "-with-rtsopts=-N" + ghc-options: -O2 -Wall -threaded "-with-rtsopts=-N" Hs-Source-Dirs: compiler/src @@ -228,6 +228,12 @@ Test-Suite gren-tests Main-Is: Spec.hs + other-modules: + Helpers.Instances + + -- tests + Parse.SpaceSpec + Build-Depends: hspec >= 2.7.10 && < 3 diff --git a/terminal/src/Repl.hs b/terminal/src/Repl.hs index a987d2d04..743aeda32 100644 --- a/terminal/src/Repl.hs +++ b/terminal/src/Repl.hs @@ -326,9 +326,9 @@ annotation = err_ _ _ _ = () in do name <- PV.lower err - PS.chompAndCheckIndent err_ err + _ <- PS.chompAndCheckIndent err_ err P.word1 0x3A {-:-} err - PS.chompAndCheckIndent err_ err + _ <- PS.chompAndCheckIndent err_ err (_, _) <- P.specialize err_ PT.expression PS.checkFreshLine err return name diff --git a/tests/Helpers/Instances.hs b/tests/Helpers/Instances.hs new file mode 100644 index 000000000..c4cac1526 --- /dev/null +++ b/tests/Helpers/Instances.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Helpers.Instances where + +import qualified AST.Source as Src +import Data.String (IsString (..)) +import qualified Data.Utf8 as Utf8 +import qualified Reporting.Error.Syntax as E + +instance Show (Utf8.Utf8 a) where + show utf8 = "\"" <> Utf8.toChars utf8 <> "\"" + +deriving instance Eq Src.Comment + +deriving instance Show Src.Comment + +deriving instance Eq E.Space + +deriving instance Show E.Space + +instance IsString (Utf8.Utf8 a) where + fromString = Utf8.fromChars diff --git a/tests/Parse/SpaceSpec.hs b/tests/Parse/SpaceSpec.hs new file mode 100644 index 000000000..acc896d23 --- /dev/null +++ b/tests/Parse/SpaceSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Parse.SpaceSpec where + +import AST.Source (Comment (..)) +import qualified Data.ByteString as BS +import Helpers.Instances () +import qualified Parse.Primitives as P +import qualified Parse.Space as Space +import Test.Hspec + +data ParseError x + = SubjectError x P.Row P.Col + | OtherError String P.Row P.Col + deriving (Eq, Show) + +spec :: Spec +spec = do + describe "chomp" $ do + let parseChomp = parse (Space.chomp SubjectError) + let parseChomp3 p1 p2 = parse $ do + () <- p1 + result <- Space.chomp SubjectError + () <- p2 + return result + + it "parses spaces and newlines" $ + parseChomp " \n " `shouldBe` Right [] + + it "parses tokens before and after" $ + parseChomp3 a b "a b" `shouldBe` Right [] + + it "allows zero whitespace" $ + parseChomp3 a b "ab" `shouldBe` Right [] + + it "parses curly brace comments" $ + parseChomp "{- 1 -}" `shouldBe` Right [BlockComment " 1 "] + + it "can parse curly brace token adjacent to whitespace" $ + parseChomp3 leftCurly leftCurly "{{- 1 -} {" + `shouldBe` Right [BlockComment " 1 "] + + it "can parse nested curly brace comments" $ + parseChomp "{- {- inner -} outer -}" + `shouldBe` Right [BlockComment " {- inner -} outer "] + + it "parses hyphen comments" $ + parseChomp "-- 1\n" `shouldBe` Right [LineComment " 1"] + + it "parses hyphen comments at end of file" $ + parseChomp "-- 1" `shouldBe` Right [LineComment " 1"] + + it "can parse hyphen adjacent to whitespace" $ + parseChomp3 hyphen hyphen "- -- 1\n-" `shouldBe` Right [LineComment " 1"] + + it "can parse nested hyphen comments" $ + parseChomp "-- outer -- inner" `shouldBe` Right [LineComment " outer -- inner"] + + it "returns comments in the correct order" $ + parseChomp "{- 1 -}{- 2 -} -- 3\n{- 4 -}\n{- 5 -}" + `shouldBe` Right + [ BlockComment " 1 ", + BlockComment " 2 ", + LineComment " 3", + BlockComment " 4 ", + BlockComment " 5 " + ] + +parse :: P.Parser (ParseError x) a -> BS.ByteString -> Either (ParseError x) a +parse parser = + P.fromByteString parser (OtherError "fromBytString failed") + +a :: P.Parser (ParseError x) () +a = P.word1 0x61 {- a -} (OtherError "Expected 'a'") + +b :: P.Parser (ParseError x) () +b = P.word1 0x62 {- b -} (OtherError "Expected 'b'") + +leftCurly :: P.Parser (ParseError x) () +leftCurly = P.word1 0x7B {- { -} (OtherError "Expected '{'") + +hyphen :: P.Parser (ParseError x) () +hyphen = P.word1 0x2D {- - -} (OtherError "Expected '-'")