1{-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# OPTIONS_GHC -O0 #-} -- otherwise it takes a lot of memory to compile on the haskell.org server
4
5module Query(
6    Query(..), isQueryName, isQueryType, isQueryScope,
7    parseQuery, renderQuery,
8    query_test
9    ) where
10
11import Data.List
12import Language.Haskell.Exts
13import Data.Char
14import Text.Blaze
15import qualified Text.Blaze.XHtml5 as H
16import Data.List.Extra
17import Data.Generics.Uniplate.Data
18import General.Util
19import Data.Maybe
20import Data.Monoid
21import Control.Applicative
22import Prelude
23
24---------------------------------------------------------------------
25-- DATA TYPE
26
27data Query
28    = QueryName {fromQueryName :: String}
29    | QueryType {fromQueryType :: Type ()}
30    | QueryScope {scopeInclude :: Bool, scopeCategory :: String, scopeValue :: String}
31    | QueryNone String -- part of the query that is ignored
32      deriving (Show,Eq)
33
34isQueryName, isQueryType, isQueryScope :: Query -> Bool
35isQueryName QueryName{} = True; isQueryName _ = False
36isQueryType QueryType{} = True; isQueryType _ = False
37isQueryScope QueryScope{} = True; isQueryScope _ = False
38
39renderQuery :: [Query] -> Markup
40renderQuery [] = H.i "No query"
41renderQuery xs = do
42    string $ unwords $
43        [x | QueryName x <- xs] ++
44        [":: " ++ pretty x | QueryType x <- xs] ++
45        [['-' | not scopeInclude] ++ scopeCategory ++ ":" ++ scopeValue | QueryScope{..} <- xs]
46    mconcat [" " <> H.del (string x) | QueryNone x <- xs]
47
48
49---------------------------------------------------------------------
50-- PARSER
51
52parseQuery :: String -> [Query]
53parseQuery x = map QueryName nam ++ map QueryType (maybeToList typ) ++ scp
54    where
55        (scp,rest) = scope_ $ lexer x
56        (nam,typ) = divide rest
57
58
59openBrackets = ["(#","[:","(","["]
60shutBrackets = ["#)",":]",")","]"]
61
62isBracket x = x `elem` (openBrackets ++ shutBrackets)
63isBracketPair x = x `elem` zipWith (++) openBrackets shutBrackets
64
65isSym x = ((isSymbol x || isPunctuation x) && x `notElem` special) || x `elem` ascSymbol
66    where special = "(),;[]`{}\"'" :: String
67          ascSymbol = "!#$%&*+./<=>?@\\^|-~" :: String
68
69isSyms xs | isBracket xs || isBracketPair xs = False
70isSyms (x:xs) = isSym x
71isSyms [] = False
72
73-- | Split into small lexical chunks.
74--
75-- > "Data.Map.(!)" ==> ["Data",".","Map",".","(","!",")"]
76lexer :: String -> [String]
77lexer ('(':',':xs) | (a,')':b) <- span (== ',') xs = ("(," ++ a ++ ")") : lexer b
78lexer x | Just s <- (bs !!) <$> findIndex (`isPrefixOf` x) bs = s : lexer (drop (length s) x)
79    where bs = zipWith (++) openBrackets shutBrackets ++ openBrackets ++ shutBrackets
80lexer (x:xs)
81    | isSpace x = " " : lexer (trimStart xs)
82    | isAlpha x || x == '_' =
83        let (a,b) = span (\x -> isAlphaNum x || x `elem` ("_'#-" :: String)) xs
84            (a1,a2) = spanEnd (== '-') a
85        in (x:a1) : lexer (a2 ++ b)
86    | isSym x = let (a,b) = span isSym xs in (x:a) : lexer b
87    | x == ',' = "," : lexer xs
88    | otherwise = lexer xs -- drop invalid bits
89lexer [] = []
90
91
92-- | Find and extract the scope annotations.
93--
94-- > +package
95-- > +module
96-- > name.bar
97-- > name.++ name.(++) (name.++)
98-- > +foo -foo
99-- > +scope:foo -scope:foo scope:foo
100scope_ :: [String] -> ([Query], [String])
101scope_ xs = case xs of
102    (readPM -> Just pm):(readCat -> Just cat):":":(readMod -> Just (mod,rest)) -> add pm cat mod rest
103    (readPM -> Just pm):(readCat -> Just cat):":-":(readMod -> Just (mod,rest)) -> add False cat mod rest
104    (readPM -> Just pm):(readMod -> Just (mod,rest)) -> add_ pm mod rest
105    (readCat -> Just cat):":":(readMod -> Just (mod,rest)) -> add True cat mod rest
106    (readCat -> Just cat):":.":(readMod -> Just (mod,rest)) -> add True cat ('.':mod) rest
107    (readCat -> Just cat):":-":(readMod -> Just (mod,rest)) -> add False cat mod rest
108    (readCat -> Just cat):":-.":(readMod -> Just (mod,rest)) -> add False cat ('.':mod) rest
109    "(":(readDots -> Just (scp,x:")":rest)) -> out ["(",x,")"] $ add_ True scp rest
110    (readDots -> Just (scp,rest)) -> add_ True scp rest
111    "(":".":(readDots -> Just (scp,x:")":rest)) -> out ["(",x,")"] $ add_ True ('.':scp) rest
112    ".":(readDots -> Just (scp,rest)) -> add_ True ('.':scp) rest
113    x:xs -> out [x] $ scope_ xs
114    [] -> ([], [])
115    where
116        out xs (a,b) = (a,xs++b)
117        add a b c rest = let (x,y) = scope_ rest in (QueryScope a b c : x, y)
118        add_ a c rest = add a b c rest
119            where b = if '.' `elem` c || any isUpper (take 1 c) then "module" else "package"
120
121        readPM x = case x of "+" -> Just True; "-" -> Just False; _ -> Nothing
122
123        readCat x | isAlpha1 x = Just x
124                  | otherwise = Nothing
125
126        readMod (x:xs) | isAlpha1 x = Just $ case xs of
127            ".":ys | Just (a,b) <- readMod ys -> (x ++ "." ++ a, b)
128            ".":[] -> (x ++ ".",[])
129            ".":" ":ys -> (x ++ "."," ":ys)
130            _ -> (x,xs)
131        readMod _ = Nothing
132
133        readDots (x:xs) | isAlpha1 x = case xs of
134            ".":ys | Just (a,b) <- readDots ys -> Just (x ++ "." ++ a, b)
135            ('.':y):ys -> Just (x, [y | y /= ""] ++ ys)
136            _ -> Nothing
137        readDots _ = Nothing
138
139
140-- | If everything is a name, or everything is a symbol, then you only have names.
141divide :: [String] -> ([String], Maybe (Type ()))
142divide xs | all isAlpha1 ns = (ns, Nothing)
143          | all isSyms ns = (ns, Nothing)
144          | length ns == 1 = (ns, Nothing)
145          | otherwise = case break (== "::") xs of
146                (nam, _:rest) -> (names_ nam, typeSig_ rest)
147                _ -> ([], typeSig_ xs)
148    where ns = names_ xs
149
150
151-- | Ignore brackets around symbols, and try to deal with tuple names.
152names_ :: [String] -> [String]
153names_ ("(":x:")":xs) = [x | x /= " "] ++ names_ xs
154names_ ["(",x] = [x]
155names_ (x:xs) = [x | x /= " "] ++ names_ xs
156names_ [] = []
157
158typeSig_ :: [String] -> Maybe (Type ())
159typeSig_ xs = case parseTypeWithMode parseMode $ unwords $ fixup $ filter (not . all isSpace) xs of
160    ParseOk x -> Just $ transformBi (\v -> if v == Ident () "__" then Ident () "_" else v) $ fmap (const ()) x
161    _ -> Nothing
162    where
163        fixup = underscore . closeBracket . completeFunc . completeArrow
164
165        completeArrow (unsnoc -> Just (a,b)) | b `elem` ["-","="] = snoc a (b ++ ">")
166        completeArrow x = x
167
168        completeFunc (unsnoc -> Just (a,b)) | b `elem` ["->","=>"] = a ++ [b,"_"]
169        completeFunc x = x
170
171        closeBracket xs = xs ++ foldl f [] xs
172            where f stack x | Just c <- lookup x (zip openBrackets shutBrackets) = c:stack
173                  f (s:tack) x | x == s = tack
174                  f stack x = stack
175
176        underscore = replace ["_"] ["__"]
177
178
179query_test :: IO ()
180query_test = testing "Query.parseQuery" $ do
181    let want s p (bad,q) = (["missing " ++ s | not $ any p q], filter (not . p) q)
182        wantEq v = want (show v) (== v)
183        name = wantEq . QueryName
184        scope b c v = wantEq $ QueryScope b c v
185        typ = wantEq . QueryType . fmap (const ()) . fromParseResult . parseTypeWithMode parseMode
186        typpp x = want ("type " ++ x) (\v -> case v of QueryType s -> pretty s == x; _ -> False)
187    let infixl 0 ===
188        a === f | bad@(_:_) <- fst $ f ([], q) = error $ show (a,q,bad :: [String])
189                | otherwise = putChar '.'
190            where q = parseQuery a
191
192    "" === id
193    "map" === name "map"
194    "#" === name "#"
195    "c#" === name "c#"
196    "-" === name "-"
197    "/" === name "/"
198    "->" === name "->"
199    "foldl'" === name "foldl'"
200    "fold'l" === name "fold'l"
201    "Int#" === name "Int#"
202    "concat map" === name "concat" . name "map"
203    "a -> b" === typ "a -> b"
204    "a->b" === typ "a -> b"
205    "(a b)" === typ "(a b)"
206    "map :: a -> b" === typ "a -> b"
207    "+Data.Map map" === scope True "module" "Data.Map" . name "map"
208    "a -> b package:foo" === scope True "package" "foo" . typ "a -> b"
209    "a -> b package:foo-bar" === scope True "package" "foo-bar" . typ "a -> b"
210    "Data.Map.map" === scope True "module" "Data.Map" . name "map"
211    "[a]" === typ "[a]"
212    "++" === name "++"
213    "(++)" === name "++"
214    ":+:" === name ":+:"
215    "bytestring-cvs +hackage" === scope True "package" "hackage" . name "bytestring-cvs"
216    "m => c" === typ "m => c"
217    "[b ()" === typ "[b ()]"
218    "[b (" === typ "[b ()]"
219    "_ -> a" === typpp "_ -> a"
220    "(a -> b) ->" === typpp "(a -> b) -> _"
221    "(a -> b) -" === typpp "(a -> b) -> _"
222    "Monad m => " === typpp "Monad m => _"
223    "map is:exact" === name "map" . scope True "is" "exact"
224    "sort set:hackage" === name "sort" . scope True "set" "hackage"
225    "sort -set:hackage" === name "sort" . scope False "set" "hackage"
226    "sort set:-hackage" === name "sort" . scope False "set" "hackage"
227    "sort -set:-hackage" === name "sort" . scope False "set" "hackage"
228    "package:bytestring-csv" === scope True "package" "bytestring-csv"
229    "(>>=)" === name ">>="
230    "(>>=" === name ">>="
231    ">>=" === name ">>="
232    "Control.Monad.mplus" === name "mplus" . scope True "module" "Control.Monad"
233    "Control.Monad.>>=" === name ">>=" . scope True "module" "Control.Monad"
234    "Control.Monad.(>>=)" === name ">>=" . scope True "module" "Control.Monad"
235    "(Control.Monad.>>=)" === name ">>=" . scope True "module" "Control.Monad"
236    "Control.Monad.(>>=" === name ">>=" . scope True "module" "Control.Monad"
237    "(Control.Monad.>>=" === name ">>=" . scope True "module" "Control.Monad"
238    "foo.bar" === name "bar" . scope True "package" "foo"
239    "insert module:.Map" === name "insert" . scope True "module" ".Map"
240    "insert module:Map." === name "insert" . scope True "module" "Map."
241    "insert module:.Map." === name "insert" . scope True "module" ".Map."
242    ".Map.insert" === name "insert" . scope True "module" ".Map"
243    ".Map." === scope True "module" ".Map"
244--  FIXME: ".Map" === scope True "module" ".Map" -- probably should work, but really needs to rewrite a fair bit
245    "(.Monad.>>=" === name ">>=" . scope True "module" ".Monad"
246--  FIXME: "author:Taylor-M.-Hedberg" === scope True "author" "Taylor-M.-Hedberg"
247    "author:Bryan-O'Sullivan" === scope True "author" "Bryan-O'Sullivan"
248    "\8801" === name "\8801"
249    "( )" === id -- FIXME: Should probably be ()
250