Work on Hoogle integration in new Persistent backend

scion-browser.cabal

@@ -69,7 +69,8 @@ library
     Scion.PersistentBrowser.ToDb,
     Scion.PersistentBrowser.Build,
     Scion.PersistentBrowser.Parser.Internal,
-    Scion.PersistentBrowser.Query
+    Scion.PersistentBrowser.Query,
+    Scion.PersistentHoogle.Parser
 
   ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -fno-warn-orphans
 

src/Scion/PersistentBrowser/DbTypes.hs

@@ -1,8 +1,10 @@
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs #-}
+
 module Scion.PersistentBrowser.DbTypes where
 
 import Database.Persist
+import Database.Persist.Base
+import Database.Persist.Sqlite
 import Database.Persist.TH
 
 data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType
@@ -44,10 +46,13 @@ DbConstructor
     declId    DbDeclId
 |]
 
+-- |Information needed to search a package.
 data DbPackageIdentifier = DbPackageIdentifier String String -- name, version
 
 dbPackageToIdentifier :: DbPackage -> DbPackageIdentifier
 dbPackageToIdentifier (DbPackage name version _) = DbPackageIdentifier name version
 
+-- |Complete information for a declaration.
+--  Look at its ToJSON instance to know which one is used in each kind of declaration.
 data DbCompleteDecl = DbCompleteDecl DbDecl [DbContext] [DbTyVar] [DbFunDep] [DbConstructor]
 

src/Scion/PersistentBrowser/Parser/Internal.hs

@@ -532,6 +532,7 @@ typeToContextAndHead t = let (ctx, ty) = getContextAndType t
                                 ((TyCon _ (Qual _ _ name')):params) -> (name', toKindedVars params) 
                                 ((TyCon _ (Special l _)):params)    -> (Symbol l "", toKindedVars params)
                                 (_:params)                          -> (Ident NoDoc "#unparsed#", toKindedVars params)
+                                []                                  -> error "This should never happen"
                          in  (ctx, DHead NoDoc name vars)
 
 toKindedVars :: [Type Doc] -> [TyVarBind Doc]

src/Scion/PersistentBrowser/Query.hs

@@ -1,12 +1,6 @@
-module Scion.PersistentBrowser.Query
-( allPackageIds
-, allPackages
-, packagesByName
-, getPackage
-, getSubmodules
-, getDeclsInModule
-, getModulesWhereDeclarationIs
-) where
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Scion.PersistentBrowser.Query where
 
 import qualified Data.Text as T
 import Database.Persist
@@ -36,6 +30,11 @@ getPackage :: DbPackageIdentifier -> SqlPersist IO (Maybe (DbPackage))
 getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] []
                                                    return $ fmap snd package
 
+-- |Get information about all modules with that name.
+modulesByName :: String -> SqlPersist IO [DbModule]
+modulesByName name = do mods <- selectList [ DbModuleName ==. name ] []
+                        return $ map snd mods
+
 -- |Get all the modules hierarchically inside the specified one.
 --  For getting the entire list of modules modules, use "" as initial name.
 getSubmodules :: String -> SqlPersist IO [DbModule]
@@ -52,6 +51,11 @@ withPopper popper = loop []
                          Just [ modId ] -> loop (modId:list)
                          _              -> error "This should not happen"
 
+-- |Get information about all declaration with that name.
+declsByName :: String -> SqlPersist IO [DbDecl]
+declsByName name = do decls <- selectList [ DbDeclName ==. name ] []
+                      return $ map snd decls
+
 -- |Gets the declarations inside some module,
 --  along with information about which package it lives.
 getDeclsInModule :: String -> SqlPersist IO [(DbPackage, [DbCompleteDecl])]
@@ -75,6 +79,11 @@ getAllDeclInfo (declId, decl) =
      let consts = map snd consts'
      return $ DbCompleteDecl decl ctxs tyvars fundeps consts
 
+-- |Get information about all constructors with that name.
+constructorsByName :: String -> SqlPersist IO [DbConstructor]
+constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] []
+                             return $ map snd consts
+
 -- | Gets a list of modules where a declaration may live
 getModulesWhereDeclarationIs :: String -> SqlPersist IO [DbModule]
 getModulesWhereDeclarationIs declName =
@@ -87,3 +96,33 @@ getModulesWhereDeclarationIs declName =
                                              return md)
           (decls ++ consDecls)
 
+-- |Things that reside on a package.
+class HasDbPackage d where
+  getDbPackage :: d -> SqlPersist IO DbPackage
+
+instance HasDbPackage DbPackage where
+  getDbPackage = return
+
+instance HasDbPackage DbModule where
+  getDbPackage (DbModule _ _ pkgId) = do Just pkg <- get pkgId
+                                         return pkg
+
+instance HasDbPackage DbDecl where
+  getDbPackage (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId
+                                               getDbPackage md
+
+-- |Things that reside on a module.
+class HasDbModule d where
+  getDbModule :: d -> SqlPersist IO DbModule
+
+instance HasDbModule DbModule where
+  getDbModule = return
+
+instance HasDbModule DbDecl where
+  getDbModule (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId
+                                              return md
+
+instance HasDbModule DbConstructor where
+  getDbModule (DbConstructor _ _ declId) = do Just dc <- get declId
+                                              getDbModule dc
+

src/Scion/PersistentBrowser/ToDb.hs

@@ -69,6 +69,8 @@ saveDeclToDb moduleId (TypeDecl doc hd ty) =
      declId <- insert $ DbDecl DbType declName (docToString doc) 
                                Nothing Nothing (Just (singleLinePrettyPrint ty)) moduleId
      mapM_ (saveTyVarToDb declId) declVars
+-- Other
+saveDeclToDb _ _ = error "This should never happen"
 
 -- saveTyVarToDb :: PersistBackend backend m => DbDeclId -> String -> backend m ()
 saveTyVarToDb declId var = insert $ DbTyVar var declId
@@ -87,14 +89,14 @@ saveConstructorToDb declId (GadtDecl _ name ty) = insert $ DbConstructor (getNam
 
 -- deletePackageByInfo :: PersistBackend backend m => PackageIdentifier -> backend m ()
 deletePackageByInfo (PackageIdentifier (PackageName name) version) =
-  do Just (packageId, _) <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] []
-     deletePackage packageId
+  do Just (pkgId, _) <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. showVersion version ] []
+     deletePackage pkgId
 
 -- deletePackage :: PersistBackend backend m => DbPackageId -> backend m ()
-deletePackage packageId =
-  do modules <- selectList [ DbModulePackageId ==. packageId ] []
+deletePackage pkgId =
+  do modules <- selectList [ DbModulePackageId ==. pkgId ] []
      mapM_ (\(moduleId, _) -> deleteModule moduleId) modules
-     delete packageId
+     delete pkgId
 
 -- deleteModule :: PersistBackend backend m => DbModuleId -> backend m ()
 deleteModule moduleId =

src/Scion/PersistentHoogle/Instances/Json.hs

@@ -0,0 +1,28 @@
+module Scion.PersistentHoogle.Instances.Json where
+
+import Control.Applicative
+import Data.Aeson hiding (Result)
+import qualified Data.Text as T
+import Scion.PersistentHoogle.Types
+
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
+    toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d]
+    {-# INLINE toJSON #-}
+
+instance ToJSON (Result) where
+  toJSON (RPackage pids)      = object [ T.pack "type"    .= "package"
+                                       , T.pack "results" .= pids
+                                       ]
+  toJSON (RModule mds)        = object [ T.pack "type"    .= "module"
+                                       , T.pack "results" .= mds
+                                       ]
+  toJSON (RDeclaration decls) = object [ T.pack "type"    .= "declaration"
+                                       , T.pack "results" .= decls
+                                       ]
+  toJSON (RConstructor decls) = object [ T.pack "type"    .= "constructor"
+                                       , T.pack "results" .= decls
+                                       ]
+
+instance FromJSON (Query) where
+  parseJSON q = Query <$> parseJSON q
+

src/Scion/PersistentHoogle/Parser.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE RankNTypes, ImpredicativeTypes #-}
+
+module Scion.PersistentHoogle.Parser where
+
+import Control.Monad (filterM)
+import Data.List (intercalate)
+import Database.Persist
+import Database.Persist.Sqlite
+import Language.Haskell.Exts.Annotated.Syntax
+import Scion.PersistentBrowser.DbTypes
+import Scion.PersistentBrowser.Parser.Internal
+import Scion.PersistentBrowser.Query
+import Scion.PersistentBrowser.ToDb
+import Scion.PersistentBrowser.Types
+import Scion.PersistentHoogle.Types
+import Text.Parsec.Char
+import Text.Parsec.Combinator
+import Text.Parsec.Prim
+
+data HalfResult = HalfPackage  String
+                | HalfModule   String (Documented Module)
+                | HalfDecl     String (Documented Decl)
+                | HalfGadtDecl String (Documented GadtDecl)
+
+hoogleElements :: BSParser (SqlPersist IO [Result])
+hoogleElements = do elts <- hoogleElements'
+                    let results = catMaybesM $ map convertHalfToResult elts
+                    return results
+
+catMaybesM :: Monad m => [m (Maybe a)] -> m [a]
+catMaybesM []     = return []
+catMaybesM (x:xs) = do y <- x
+                       zs <- catMaybesM xs
+                       case y of
+                         Nothing -> return zs
+                         Just z  -> return (z:zs)
+
+hoogleElements' :: BSParser [HalfResult]
+hoogleElements' =   try (do spaces0
+                            eof
+                            return [])
+                <|> (do first <- hoogleElement
+                        rest <- many $ try (try eol >> try hoogleElement)
+                        spaces
+                        eof
+                        return $ first:rest)
+
+hoogleElement :: BSParser HalfResult
+hoogleElement =   try (do pname <- hooglePackageName
+                          return $ HalfPackage pname)
+              <|> try (do (mname, m) <- moduled (module_ NoDoc)
+                          return $ HalfModule mname m)
+              <|> try (do (mname, d) <- moduled (function NoDoc)
+                          return $ HalfDecl mname d)
+              <|> try (do (mname, d) <- moduled (dataHead NoDoc)
+                          return $ HalfDecl mname d)
+              <|> try (do (mname, d) <- moduled (newtypeHead NoDoc)
+                          return $ HalfDecl mname d)
+              <|> try (do (mname, d) <- moduled (type_ NoDoc)
+                          return $ HalfDecl mname d)
+              <|> try (do (mname, d) <- moduled (class_ NoDoc)
+                          return $ HalfDecl mname d)
+              <|> try (do (mname, d) <- moduled (constructor NoDoc)
+                          return $ HalfGadtDecl mname d)
+
+moduled :: BSParser a -> BSParser (String, a)
+moduled p = try (do mname <- try conid `sepBy` char '.'
+                    let name = intercalate "." (map getid mname)
+                    try spaces1
+                    rest <- p
+                    return (name, rest))
+
+hooglePackageName :: BSParser String
+hooglePackageName = do string "package"
+                       spaces1
+                       name <- restOfLine
+                       spaces0
+                       return name
+
+convertHalfToResult :: HalfResult -> SqlPersist IO (Maybe Result)
+convertHalfToResult (HalfPackage  pname) = 
+  do pkgs <- packagesByName pname
+     case pkgs of
+       [] -> return Nothing
+       p  -> return $ Just (RPackage p)
+convertHalfToResult (HalfModule mname _) =
+  do mods <- modulesByName mname
+     case mods of
+       [] -> return Nothing
+       m  -> do pm <- mapM (\md -> do pkg <- getDbPackage md
+                                      return (dbPackageToIdentifier pkg, md)) m
+                return $ Just (RModule pm)
+convertHalfToResult (HalfDecl mname dcl) =
+  -- TODO: Check the rest of the things
+  do decls <- selectList [ DbDeclName ==. (getName dcl) ] []
+     filteredDecls <- filterM (\(_, dc) -> do (DbModule mn _ _) <- getDbModule dc
+                                              return $ mn == mname) decls
+     case filteredDecls of
+       [] -> return Nothing
+       d  -> do dm <- mapM (\(declId, dc) -> do md@(DbModule mn _ _) <- getDbModule dc
+                                                pkg <- getDbPackage md
+                                                completeDecl <- getAllDeclInfo (declId, dc)
+                                                return (dbPackageToIdentifier pkg, mn, completeDecl)) d
+                return $ Just (RDeclaration dm)
+convertHalfToResult (HalfGadtDecl mname dcl) =
+  do consts <- constructorsByName (getName dcl)
+     filteredConsts <- filterM (\dc -> do (DbModule mn _ _) <- getDbModule dc
+                                          return $ mn == mname) consts
+     case filteredConsts of
+       [] -> return Nothing
+       c  -> do dm <- mapM (\ct@(DbConstructor _ _ declId) -> 
+                                  do Just dc <- get declId
+                                     completeDecl <- getAllDeclInfo (declId, dc)
+                                     md@(DbModule mn _ _) <- getDbModule dc
+                                     pkg <- getDbPackage md
+                                     return (dbPackageToIdentifier pkg, mn, completeDecl, ct)) c
+                return $ Just (RConstructor dm)
+
+checkEqualInDb :: Documented Decl -> DbCompleteDecl -> Bool
+checkEqualInDb (GDataDecl _ (DataType _) ctx (DHead _ name vars) knd _ _) (DbCompleteDecl (DbDecl DbData dbName _ dbKind _ _ _) dbCtx dbVars _ _) =
+     (getNameString name) == dbName
+  && (map singleLinePrettyPrint vars) == (map (\(DbTyVar vn _) -> vn) dbVars)
+  && (contextToDb (maybeEmptyContext ctx)) == (map (\(DbContext s _) -> s) dbCtx)
+  && (fmap singleLinePrettyPrint knd) == dbKind
+checkEqualInDb (GDataDecl _ (NewType _) ctx (DHead _ name vars) knd _ _) (DbCompleteDecl (DbDecl DbNewType dbName _ dbKind _ _ _) dbCtx dbVars _ _) =
+     (getNameString name) == dbName
+  && (map singleLinePrettyPrint vars) == (map (\(DbTyVar vn _) -> vn) dbVars)
+  && (contextToDb (maybeEmptyContext ctx)) == (map (\(DbContext s _) -> s) dbCtx)
+  && (fmap singleLinePrettyPrint knd) == dbKind
+checkEqualInDb (ClassDecl _ ctx (DHead _ name vars) fdeps _) (DbCompleteDecl (DbDecl DbClass dbName _ _ _ _ _) dbCtx dbVars dbFunDeps _) =
+     (getNameString name) == dbName
+  && (map singleLinePrettyPrint vars) == (map (\(DbTyVar vn _) -> vn) dbVars)
+  && (contextToDb (maybeEmptyContext ctx)) == (map (\(DbContext s _) -> s) dbCtx)
+  && (map singleLinePrettyPrint fdeps) == (map (\(DbFunDep fd _) -> fd) dbFunDeps)
+checkEqualInDb (InstDecl _ ctx (IHead _ name vars) _) (DbCompleteDecl (DbDecl DbInstance dbName _ _ _ _ _) dbCtx dbVars _ _) =
+     (getQNameString name) == dbName
+  && (map singleLinePrettyPrint vars) == (map (\(DbTyVar vn _) -> vn) dbVars)
+  && (contextToDb (maybeEmptyContext ctx)) == (map (\(DbContext s _) -> s) dbCtx)
+checkEqualInDb (TypeSig _ [ name ] ty) (DbCompleteDecl (DbDecl DbSignature dbName _ _ dbSignature _ _) _ _ _ _) =
+     (getNameString name) == dbName
+  && Just (singleLinePrettyPrint ty) == dbSignature
+checkEqualInDb (TypeDecl _ (DHead _ name vars) ty) (DbCompleteDecl (DbDecl DbType dbName _ _ _ dbEquals _) _ dbVars _ _) =
+     (getNameString name) == dbName
+  && (map singleLinePrettyPrint vars) == (map (\(DbTyVar vn _) -> vn) dbVars)
+  && Just (singleLinePrettyPrint ty) == dbEquals
+checkEqualInDb _ _ = False
+

src/Scion/PersistentHoogle/Types.hs

@@ -0,0 +1,13 @@
+module Scion.PersistentHoogle.Types where
+
+import Scion.PersistentBrowser.DbTypes
+
+type Results = [Result]
+
+data Result = RPackage     [DbPackage]
+            | RModule      [(DbPackageIdentifier, DbModule)]
+            | RDeclaration [(DbPackageIdentifier, String, DbCompleteDecl)]
+            | RConstructor [(DbPackageIdentifier, String, DbCompleteDecl, DbConstructor)]
+
+data Query = Query String
+