Skip to content
Browse files

ast creation seems to work

  • Loading branch information...
1 parent 847d9f1 commit 4330a6bef4d98702b4007211fb987ca394674734 @phischu committed Mar 29, 2013
Showing with 84 additions and 19 deletions.
  1. +3 −1 Master.cabal
  2. +1 −1 Master.hs
  3. +80 −17 MasterPipe.hs
View
4 Master.cabal
@@ -27,7 +27,9 @@ executable Master
errors,
pipes,
pipes-safe,
- haskell-src-exts
+ haskell-src-exts,
+ bytestring,
+ aeson
default-language: Haskell2010
ghc-options: -rtsopts -threaded -auto-all -caf-all
View
2 Master.hs
@@ -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))
View
97 MasterPipe.hs
@@ -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,forM_)
+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(..),
@@ -26,13 +28,17 @@ 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
+
masterpipe :: IO ()
masterpipe = runSafeIO $ runProxy $ runEitherK $
packages >->
tryK (memoPipe loadConfigurations configurations saveConfigurations) >->
tryK modules >->
- tryK (memoPipe loadASTs asts saveASTs)
+ mapP (memoPipe loadASTs asts saveASTs)
memoPipe :: (Proxy p,ListT p,Monad m) =>
(() -> Pipe p a (Either a b) m ()) ->
@@ -111,21 +117,78 @@ modules () = runIdentityP $ forever $ do
case configuration of
Left _ -> return ()
Right (modules,cppoptions) -> forM_ modules (\modul->respond (package,modul,cppoptions))
-
-loadASTs :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,CPPOptions) (Either (Package,Module,CPPOptions) (Package,Module,AST.Module)) IO ()
-loadASTs = mapD Left
-
-asts :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,CPPOptions) (Package,Module,AST.Module) IO ()
-asts () = runIdentityP $ forever $ do
+{-
+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 Module _ path = modul
- mode = defaultParseMode {parseFilename = path, fixities = Just baseFixities}
- parseresult <- lift (parseFileWithMode mode path)
- case parseresult of
- ParseFailed _ _ -> return ()
- ParseOk ast -> respond (package,modul,ast)
-
-saveASTs :: (Proxy p,CheckP p) => () -> Pipe p (Package,Module,AST.Module) (Package,Module,AST.Module) IO ()
-saveASTs = idT
+ 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)
+

0 comments on commit 4330a6b

Please sign in to comment.
Something went wrong with that request. Please try again.