@@ -0,0 +1,119 @@
1+module Spago.Search.TypeQuery where
2+
3+import Prelude
4+
5+import Control.Alt ((<|>))
6+import Data.Array as Array
7+import Data.Either (Either)
8+import Data.Foldable (foldl)
9+import Data.Generic.Rep (class Generic)
10+import Data.Generic.Rep.Show (genericShow)
11+import Data.List (List, some, (:))
12+import Data.List as List
13+import Data.List.NonEmpty (NonEmptyList, cons', uncons)
14+import Data.Maybe (Maybe(..))
15+import Data.String.CodeUnits (fromCharArray)
16+import Data.Tuple (Tuple(..))
17+import Text.Parsing.StringParser (ParseError, Parser, runParser, try)
18+import Text.Parsing.StringParser.CodePoints (alphaNum, anyLetter, char, eof, lowerCaseChar, skipSpaces, string, upperCaseChar)
19+import Text.Parsing.StringParser.Combinators (fix, sepBy, sepBy1, sepEndBy, sepEndBy1)
20+
21+data TypeQuery
22+ = QAny String
23+ | QConcrete String
24+ | QFun TypeQuery TypeQuery
25+ | QApp TypeQuery TypeQuery
26+ | QForAll (NonEmptyList String) TypeQuery
27+ | QConstraint String (List String) TypeQuery
28+ | QRow (List (Tuple String TypeQuery))
29+ | QEmpty
30+
31+derive instance eqTypeQuery :: Eq TypeQuery
32+derive instance genericTypeQuery :: Generic TypeQuery _
33+
34+instance showTypeQuery :: Show TypeQuery where
35+ show x = genericShow x
36+
37+parseTypeQuery :: String -> Either ParseError TypeQuery
38+parseTypeQuery = runParser (typeQueryParser <* eof)
39+
40+typeQueryParser :: Parser TypeQuery
41+typeQueryParser = fix \typeQuery ->
42+ let rowFields =
43+ QRow <$> sepBy (Tuple <$> (skipSpaces *> ident <* skipSpaces <* string "::") <*>
44+ (skipSpaces *> typeQuery <* skipSpaces))
45+ (string "," *> skipSpaces)
46+
47+ row = string "{" *> rowFields <* string "}"
48+
49+ binders =
50+ string "forall" *> some space *> sepEndBy1 ident (some space) <* string "." <* skipSpaces
51+
52+ for_all = QForAll <$> binders <*> typeQuery
53+
54+ parens =
55+ string "(" *> skipSpaces *> typeQuery <* skipSpaces <* string ")"
56+
57+ atom = skipSpaces *> (
58+ for_all <|>
59+ parens <|>
60+ row <|>
61+ concrete <|>
62+ any
63+ )
64+
65+ apps =
66+ foldl1 QApp <$> sepEndBy1 atom (some space)
67+
68+ funs =
69+ foldr1 QFun <$> sepBy1 apps (string "->" *> skipSpaces)
70+
71+ constrained =
72+ QConstraint <$> (upperCaseIdent <* some space) <*>
73+ (sepEndBy ident (some space) <* string "=>") <*>
74+ funs
75+ in
76+ try constrained <|> funs
77+
78+foldl1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
79+foldl1 f as =
80+ case uncons as of
81+ { head, tail } -> foldl f head tail
82+
83+foldr1 :: forall a. (a -> a -> a) -> NonEmptyList a -> a
84+foldr1 f = go List.Nil
85+ where
86+ go acc x = case uncons x of
87+ { head, tail } -> case List.uncons tail of
88+ Nothing -> List.foldl (flip f) head acc
89+ Just { head: head1, tail: tail1 } ->
90+ go (head : acc) (cons' head1 tail1)
91+
92+any :: Parser TypeQuery
93+any = do
94+ QAny <$> lowerCaseIdent
95+
96+concrete :: Parser TypeQuery
97+concrete =
98+ QConcrete <$> upperCaseIdent
99+
100+ident :: Parser String
101+ident = do
102+ head <- anyLetter
103+ rest <- Array.many alphaNum
104+ pure $ fromCharArray $ pure head <> rest
105+
106+upperCaseIdent :: Parser String
107+upperCaseIdent = do
108+ head <- upperCaseChar
109+ rest <- Array.many alphaNum
110+ pure $ fromCharArray $ pure head <> rest
111+
112+lowerCaseIdent :: Parser String
113+lowerCaseIdent = do
114+ head <- lowerCaseChar
115+ rest <- Array.many alphaNum
116+ pure $ fromCharArray $ pure head <> rest
117+
118+space :: Parser Char
119+space = char ' '