Add a ModuleParser

Author: klntsky

src/Docs/Search/ModuleParser.purs

@@ -0,0 +1,50 @@
+module Docs.Search.ModuleParser where
+
+import Prelude
+
+import Control.Alt ((<|>))
+import Data.Either (hush)
+import Data.Foldable (intercalate)
+import Data.Maybe (Maybe)
+import Data.Newtype (wrap)
+import Docs.Search.Types (ModuleName)
+import StringParser (Parser, char, choice, fix, many, manyTill, noneOf, regex, runParser, sepBy, sepBy1, string, try, whiteSpace)
+
+parseModuleName :: String -> Maybe ModuleName
+parseModuleName = map wrap <<< hush <<< runParser do
+  void $ many whiteSpaceOrComment
+  moduleHeader
+
+whiteSpaceOrComment :: Parser Unit
+whiteSpaceOrComment =
+  choice
+  [ try $ multiLineComment
+  , try $ singleLineComment
+  , try $ void whiteSpace
+  ]
+
+multiLineComment :: Parser Unit
+multiLineComment = do
+  void $ string "{-"
+  void $ manyTill (void $ noneOf []) (string "-}")
+
+singleLineComment :: Parser Unit
+singleLineComment = do
+  void $ string "--"
+  void $ manyTill (void $ noneOf ['\n']) (char '\n')
+
+
+moduleHeader :: Parser String
+moduleHeader = do
+  void $ string "module"
+  void $ many whiteSpaceOrComment
+  moduleName
+
+moduleName :: Parser String
+moduleName = sepBy1 moduleNameWord (string ".") <#> intercalate "."
+
+moduleNameWord :: Parser String
+moduleNameWord = do
+  first <- regex "[A-Z]"
+  rest <- regex "[a-z0-9]*"
+  pure $ first <> rest

src/Docs/Search/Types.purs

@@ -31,6 +31,9 @@ derive newtype instance ordModuleName :: Ord ModuleName
 derive newtype instance decodeJsonModuleName :: DecodeJson ModuleName
 derive newtype instance encodeJsonModuleName :: EncodeJson ModuleName
 
+instance Show ModuleName where
+  show = genericShow
+
 
 -- | Non-normalized package name, e.g. `purescript-prelude` or just `prelude`.
 newtype RawPackageName = RawPackageName String
@@ -55,14 +58,14 @@ data PackageInfo = LocalPackage | Builtin | Package PackageName | UnknownPackage
 derive instance eqPackageInfo :: Eq PackageInfo
 derive instance ordPackageInfo :: Ord PackageInfo
 derive instance genericPackageInfo :: Generic PackageInfo _
-instance showPackageInfo :: Show PackageInfo where
-  show = genericShow
-
 instance decodeJsonPackageInfo :: DecodeJson PackageInfo where
   decodeJson = genericDecodeJson
 instance encodeJsonPackageInfo :: EncodeJson PackageInfo where
   encodeJson = genericEncodeJson
 
+instance showPackageInfo :: Show PackageInfo where
+  show = genericShow
+
 
 newtype PackageScore = PackageScore Int
 

test/Main.purs

@@ -3,16 +3,16 @@ module Test.Main where
 import Prelude
 
 import Effect (Effect)
+import Effect.Aff (launchAff_)
 import Test.Declarations as Declarations
 import Test.IndexBuilder as IndexBuilder
 import Test.ModuleIndex as ModuleIndex
-import Test.TypeQuery as TypeQuery
-import Test.TypeJson as TypeJson
--- import Test.UI as UI
+import Test.ModuleParser as ModuleParser
 import Test.Spec (Spec)
 import Test.Spec.Reporter.Console (consoleReporter)
 import Test.Spec.Runner (runSpec)
-import Effect.Aff (launchAff_)
+import Test.TypeJson as TypeJson
+import Test.TypeQuery as TypeQuery
 
 main :: Effect Unit
 main = do
@@ -21,6 +21,7 @@ main = do
 
 mainTest :: Spec Unit
 mainTest = do
+  ModuleParser.tests
   TypeQuery.tests
   TypeJson.tests
   IndexBuilder.tests

test/Test/ModuleParser.purs

@@ -0,0 +1,42 @@
+module Test.ModuleParser where
+
+import Prelude
+
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Docs.Search.ModuleParser (multiLineComment, parseModuleName, singleLineComment)
+import Docs.Search.Types (ModuleName(..))
+import StringParser (runParser)
+import Test.Spec (Spec, describe, it)
+import Test.Spec.Assertions (shouldEqual)
+
+
+tests :: Spec Unit
+tests = do
+  describe "ModuleParser" do
+    it "test #0" do
+      parseModuleName "module Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "test #1" do
+      parseModuleName "module Foo.Bar.B" `shouldEqual` Just (ModuleName "Foo.Bar.B")
+    it "test #2" do
+      parseModuleName "   module Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "test #3" do
+      parseModuleName " {- asdas -} module Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "test #4" do
+      parseModuleName "{--}module Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "test #5" do
+      parseModuleName "--\nmodule Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "test #6" do
+      parseModuleName "--\n-- foo\nmodule Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "test #7" do
+      parseModuleName "-- \n  -- foo\n {- bar -} --baz\n module Foo" `shouldEqual` Just (ModuleName "Foo")
+    it "multiline comment #1" do
+      runParser multiLineComment "{--}" `shouldEqual` Right unit
+    it "multiline comment #1" do
+      runParser multiLineComment "{- foo -}" `shouldEqual` Right unit
+    it "multiline comment #1" do
+      runParser multiLineComment "{- foo\nbar\nbar\n -}" `shouldEqual` Right unit
+    it "single line comment #1" do
+      runParser singleLineComment "-- asd\n" `shouldEqual` Right unit
+    it "single line comment #1" do
+      runParser singleLineComment "--\n" `shouldEqual` Right unit