Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
  • 4 commits
  • 3 files changed
  • 0 commit comments
  • 1 contributor
Showing with 109 additions and 11 deletions.
  1. +4 −1 Master.cabal
  2. +1 −1  Master.hs
  3. +104 −9 MasterPipe.hs
5 Master.cabal
View
@@ -26,7 +26,10 @@ executable Master
filepath,
errors,
pipes,
- pipes-safe
+ pipes-safe,
+ haskell-src-exts,
+ bytestring,
+ aeson
default-language: Haskell2010
ghc-options: -rtsopts -threaded -auto-all -caf-all
2  Master.hs
View
@@ -77,7 +77,7 @@ main = shakeArgs shakeOptions {shakeThreads = 4} $ do
need ["00-index.tar"]
hackage <- liftIO (readHackage' "00-index.tar")
let packages = [Package (name,renderVersion version)| name <- M.keys hackage, version <- M.keys (hackage M.! name)]
- return (PackageList (every 1 packages))))
+ return (PackageList (every 1000 packages))))
rule (\(ExtractedPackage package@(Package (name,version))) -> Just $ do
exists <- liftIO (IO.doesDirectoryExist (extractedDirectory++name++"-"++version))
113 MasterPipe.hs
View
@@ -1,12 +1,14 @@
+{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
module MasterPipe where
import Control.Proxy
import Control.Proxy.Safe
import Control.Proxy.Safe.Prelude
-import Control.Monad (filterM,when)
+import Control.Monad (filterM,when,forM_,void)
import System.Directory (doesFileExist,createDirectoryIfMissing)
import System.FilePath
+import Control.Exception (ErrorCall(ErrorCall))
import Distribution.PackageDescription
(PackageDescription(..),Library(..),libModules,BuildInfo(..),
@@ -21,11 +23,32 @@ import Distribution.Text (disp)
import Distribution.ModuleName (toFilePath)
import qualified Data.Version as V (Version(Version))
+import Language.Haskell.Exts (parseFileWithMode)
+import Language.Haskell.Exts.Fixity (baseFixities)
+import Language.Haskell.Exts.Parser (ParseMode(..),defaultParseMode,ParseResult(ParseOk,ParseFailed))
+import qualified Language.Haskell.Exts.Syntax as AST
+
+import GHC.Generics
+import qualified Data.ByteString.Lazy as BS
+import Data.Aeson.Generic
+
+type Stats = Integer
masterpipe :: IO ()
-masterpipe = runSafeIO $ runProxy $ runEitherK $
- packages >->
- tryK (loadConfigurations >-> leftD configurations >-> mapD (either id id) >-> saveConfigurations)
+masterpipe = do
+ result <- trySafeIO $ flip runStateT 0 $ runProxy $ runEitherK $
+ raiseK packages >->
+ raiseK (tryK (memoPipe loadConfigurations configurations saveConfigurations)) >->
+ raiseK (tryK modules) >->
+ raiseK (mapP (memoPipe loadASTs asts saveASTs))
+ writeFile "result.txt" (show result)
+
+memoPipe :: (Proxy p,ListT p,Monad m) =>
+ (() -> Pipe p a (Either a b) m ()) ->
+ (() -> Pipe p a b m ()) ->
+ (() -> Pipe p b b m ()) ->
+ (() -> Pipe p a b m ())
+memoPipe load work save = load >-> leftD work >-> mapD (either id id) >-> save
data Package = Package Name Version FilePath deriving (Show,Read,Eq)
type Name = String
@@ -92,11 +115,83 @@ data Module = Module Name FilePath deriving (Show,Read)
data CPPOptions = CPPOptions [String] deriving (Show,Read)
modules :: (Proxy p,CheckP p,Monad m) => () -> Pipe p (Package,Configuration) (Package,Module,CPPOptions) m ()
-modules = undefined
-
-data AST = AST
+modules () = runIdentityP $ forever $ do
+ (package,Configuration configuration) <- request ()
+ case configuration of
+ Left _ -> return ()
+ Right (modules,cppoptions) -> forM_ modules (\modul->respond (package,modul,cppoptions))
+{-
+deriving instance Generic AST.Module
+deriving instance Generic AST.Decl
+deriving instance Generic AST.ImportDecl
+deriving instance Generic AST.Annotation
+deriving instance Generic AST.ExportSpec
+deriving instance Generic AST.ImportSpec
+deriving instance Generic AST.Activation
+deriving instance Generic AST.Exp
+deriving instance Generic AST.WarningText
+deriving instance Generic AST.Rule
+deriving instance Generic AST.ModuleName
+deriving instance Generic AST.CName
+deriving instance Generic AST.XAttr
+instance FromJSON AST.Module
+instance FromJSON AST.Decl
+instance FromJSON AST.ImportDecl
+instance FromJSON AST.Annotation
+instance FromJSON AST.ExportSpec
+instance FromJSON AST.ImportSpec
+instance FromJSON AST.Activation
+instance FromJSON AST.Exp
+instance FromJSON AST.WarningText
+instance FromJSON AST.Rule
+instance FromJSON AST.ModuleName
+instance FromJSON AST.CName
+instance FromJSON AST.XAttr
+-}
+loadASTs :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,CPPOptions) (Either (Package,Module,CPPOptions) (Package,Module,AST.Module)) SafeIO ()
+loadASTs () = runIdentityP $ forever $ void $ runEitherP $ do
+ (package,modul,cppoptions) <- request ()
+ let path = astpath package modul
+ exists <- tryIO (doesFileExist path)
+ if exists
+ then do
+ maybeast <- fmap decode (tryIO (BS.readFile path))
+ case maybeast of
+ Nothing -> respond (Left (package,modul,cppoptions))
+ Just ast -> respond (Right (package,modul,ast))
+ else respond (Left (package,modul,cppoptions))
+
+asts :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,CPPOptions) (Package,Module,AST.Module) SafeIO ()
+asts () = runIdentityP $ forever $ void $ runEitherP $ do
+ (package,modul,cppoptions) <- request ()
+ let Package packagename packageversion packagepath = package
+ Module modulename modulepath = modul
+ mode = defaultParseMode {parseFilename = modulepath, fixities = Just baseFixities}
+ maybeast <- tryIO (do
+ parseresult <- parseFileWithMode mode modulepath
+ case parseresult of
+ ParseFailed _ _ -> return Nothing
+ ParseOk ast -> return (Just ast)) `catch`
+ (\(ErrorCall err)->do
+ --tryIO (putStrLn (packagename++"-"++modulename++": " ++err))
+ return Nothing)
+ case maybeast of
+ Nothing -> return ()
+ Just ast -> respond (package,modul,ast)
+
+astpath :: Package -> Module -> FilePath
+astpath (Package packagename packageversion packagepath) (Module modulename modulepath) = concat
+ ["ASTs/",packagename,"/",packageversion,"/",modulename,"/",packagename,"-",packageversion,"_",modulename,".ast.json"]
+
+saveASTs :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,AST.Module) (Package,Module,AST.Module) SafeIO ()
+saveASTs () = runIdentityP $ forever $ void $ runEitherP $ do
+ (package,modul,ast) <- request ()
+ let path = astpath package modul
+ exists <- tryIO (doesFileExist path)
+ when (not exists) (do
+ tryIO (createDirectoryIfMissing True (dropFileName path))
+ tryIO (BS.writeFile path (encode ast)))
+ respond (package,modul,ast)
-asts :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,CPPOptions) (Package,Module,AST) IO ()
-asts = undefined

No commit comments for this range

Something went wrong with that request. Please try again.