Merge pull request #88 from jneira/dhall-cache

Use dhall builtin cache to speed up etlas.dhall use

etlas/Distribution/Client/IndexUtils.hs

@@ -80,7 +80,9 @@ import Distribution.Client.Setup
 import Distribution.Simple.Command
 import qualified Distribution.Simple.Eta as Eta
 import qualified Distribution.Client.PackageDescription.Dhall as PackageDesc.Parse
-         ( readGenericPackageDescription, parseGenericPackageDescriptionFromDhall )
+         ( readGenericPackageDescription )
+import qualified Distribution.Client.PackageDescription.Dhall as PackageDescription.Dhall
+         ( parse )
 #ifdef CABAL_PARSEC
 import Distribution.PackageDescription.Parsec
          ( parseGenericPackageDescriptionMaybe, parseGenericPackageDescription, runParseResult  )
@@ -545,7 +547,7 @@ extractPkg verbosity entry blockNo = case Tar.entryContent entry of
                     Nothing -> error $ "Couldn't read etlas or cabal file "
                                      ++ show fileName
               parsed = if takeExtension fileName == ".dhall"
-                then fmap Just $ PackageDesc.Parse.parseGenericPackageDescriptionFromDhall fileName
+                then fmap Just $ PackageDescription.Dhall.parse fileName
                                $ StrictText.decodeUtf8 $ BS.toStrict content
                 else return $
 #ifdef CABAL_PARSEC
@@ -842,8 +844,8 @@ packageListFromCache verbosity mkPkg idxFile hnd Cache{..} mode patchesDir
     parsePackageDescription :: FilePath -> ByteString -> IO GenericPackageDescription
     parsePackageDescription fileName content = do
       if takeExtension fileName == ".dhall"
-        then PackageDesc.Parse.parseGenericPackageDescriptionFromDhall fileName
-                     $ StrictText.decodeUtf8 $ BS.toStrict content
+        then PackageDescription.Dhall.parse fileName
+               $ StrictText.decodeUtf8 $ BS.toStrict content
         else
 #ifdef CABAL_PARSEC
           do

etlas/Distribution/Client/Init.hs

@@ -844,7 +844,7 @@ generateCabalFile fileName c =
                 (Just "Extra files to be distributed with the package, such as examples or a README.")
                 True
 
-       , field  "cabal-version" (Flag $ orLaterVersion (mkVersion [1,10]))
+       , field  "cabal-version" (Flag $ mkVersion [1,12])
                 (Just "Constraint on the version of Cabal needed to build this package.")
                 False
 

etlas/Distribution/Client/PackageDescription/Dhall.hs

@@ -1,68 +1,86 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, RecordWildCards, OverloadedStrings #-}
 module Distribution.Client.PackageDescription.Dhall where
 
+import Control.Exception ( throwIO )
+import qualified Control.Monad.Trans.State.Strict as State
+
+import qualified Crypto.Hash
+
 import Data.Function ( (&) )
+import qualified Data.Hashable as Hashable
+import Data.Maybe ( fromMaybe )
+import Data.Semigroup ( (<>) )
 
 import qualified Data.Text as StrictText
 import qualified Data.Text.IO as StrictText
 
+import Data.Word ( Word64 )
+
 import qualified Dhall
-import DhallToCabal (dhallToCabal)
+import qualified Dhall.Binary as Dhall
+import qualified Dhall.Core as Dhall
+  hiding ( Type )
+import qualified Dhall.Context
+import qualified Dhall.Import as Dhall
+  hiding ( startingContext, standardVersion )
+import qualified Dhall.Import ( standardVersion )
+import qualified Dhall.Parser as Dhall
+import qualified Dhall.TypeCheck as Dhall
+
+import DhallToCabal ( genericPackageDescription  ) 
 
 import Distribution.Verbosity
 import Distribution.PackageDescription.PrettyPrint
-       (writeGenericPackageDescription)
+       ( writeGenericPackageDescription )
 #ifdef CABAL_PARSEC
 import qualified Data.ByteString.Char8 as BS.Char8
 import qualified Distribution.PackageDescription.Parsec as Cabal.Parse
-       (readGenericPackageDescription, parseGenericPackageDescriptionMaybe) 
+       ( readGenericPackageDescription
+       , parseGenericPackageDescriptionMaybe
+       ) 
 #else
 import Distribution.PackageDescription.Parse as Cabal.Parse
-       (readGenericPackageDescription , parseGenericPackageDescription, ParseResult(..))
+       ( readGenericPackageDescription
+       , parseGenericPackageDescription
+       , ParseResult(..)
+       )
 #endif
-import Distribution.Simple.Utils (die', info, createDirectoryIfMissingVerbose)
+import Distribution.Simple.Utils
+       ( info
+       , createDirectoryIfMissingVerbose
+       )
 import Distribution.PackageDescription
 import Distribution.Types.Dependency
 import Distribution.Types.ForeignLib
 import Distribution.Types.UnqualComponentName
 import Distribution.Types.CondTree
 
 import qualified Lens.Micro as Lens
-import Lens.Micro (Lens')
+import Lens.Micro ( Lens' )
 import qualified Lens.Micro.Extras as Lens
 
-import System.Directory (doesFileExist)
-import System.FilePath (takeDirectory, takeExtension, (</>))
-import System.CPUTime (getCPUTime)
-import Control.Monad    (unless)
+import Numeric (showHex)
 
+import System.CPUTime ( getCPUTime )
+import System.Directory
+       ( createDirectoryIfMissing
+       , doesFileExist
+       , canonicalizePath
+       )
+import System.FilePath
+       ( takeDirectory
+       , takeExtension
+       , (</>)
+       )
+
 readGenericPackageDescription :: Verbosity -> FilePath
                               -> IO GenericPackageDescription
 readGenericPackageDescription verbosity path =
   if (takeExtension path) == ".dhall" then
-    readDhallGenericPackageDescription verbosity path
+    readFromCache verbosity path
   else
     Cabal.Parse.readGenericPackageDescription verbosity path
 
-readDhallGenericPackageDescription :: Verbosity -> FilePath
-                                   -> IO GenericPackageDescription
-readDhallGenericPackageDescription verbosity dhallFilePath = do
-  exists <- doesFileExist dhallFilePath
-  unless exists $
-    die' verbosity $
-      "Error Parsing: file \"" ++ dhallFilePath ++ "\" doesn't exist. Cannot continue."
-
-  source <- StrictText.readFile dhallFilePath
-  info verbosity $ "Reading package configuration from " ++ dhallFilePath
-  start <- getCPUTime
-  gpd <- explaining $ parseGenericPackageDescriptionFromDhall dhallFilePath source
-  end   <- getCPUTime
-  let diff = (fromIntegral (end - start)) / (10^(12 :: Integer))
-  info verbosity $ "Configuration readed in " ++ show (diff :: Double) ++ " seconds"
-  return gpd
-
-  where explaining = if verbosity >= verbose then Dhall.detailed else id
-
 parseCabalGenericPackageDescription :: String
                                     -> Maybe GenericPackageDescription
 #ifdef CABAL_PARSEC
@@ -75,23 +93,170 @@ parseCabalGenericPackageDescription content =
         _             -> Nothing
 #endif
 
-parseGenericPackageDescriptionFromDhall :: FilePath -> StrictText.Text
-                                        -> IO GenericPackageDescription  
-parseGenericPackageDescriptionFromDhall dhallFilePath content = do
-  let settings = Dhall.defaultInputSettings
+
+measuringTime :: Verbosity -> String -> IO a -> IO a
+measuringTime verbosity msg action = do
+  start <- getCPUTime
+  x <- action
+  end <- getCPUTime
+  let diff = (fromIntegral (end - start)) / (10^(12 :: Integer))
+  info verbosity $ msg ++ show (diff :: Double) ++ " seconds"
+  return x
+
+
+readFromCache :: Verbosity -> FilePath -> IO GenericPackageDescription
+readFromCache verbosity dhallFilePath  = do
+  fileWithDhallHashPath <- getFileWithDhallHashFilePath dhallFilePath
+  exists <- doesFileExist fileWithDhallHashPath
+
+  gpd <-
+    if exists then measuringTime verbosity "Configuration readed in " $ do
+      expectedHash <- StrictText.readFile fileWithDhallHashPath
+
+      let expectedHashStr = StrictText.unpack expectedHash
+
+      info verbosity $ "Reading package configuration from dhall cache using hash: "
+        ++ expectedHashStr ++ " stored in file: " ++ fileWithDhallHashPath
+
+      let cacheImport = "missing sha256:" <> expectedHash 
+
+      parse dhallFilePath cacheImport
+
+    else do
+      info verbosity $ "Missing file with dhall cache hash: "
+                     ++ fileWithDhallHashPath
+      readAndCache verbosity dhallFilePath
+
+  let explaining = if verbosity >= verbose then Dhall.detailed else id
+
+  explaining $ return gpd
+
+
+parse :: FilePath -> StrictText.Text -> IO GenericPackageDescription  
+parse dhallFilePath src = do
+  ( _, expr ) <- parseAndHash dhallFilePath src
+
+  extract expr
+
+
+readAndCache :: Verbosity -> FilePath -> IO GenericPackageDescription
+readAndCache verbosity dhallFilePath = do
+  info verbosity $ "Reading and caching package configuration from dhall file: "
+                ++ dhallFilePath
+
+  measuringTime verbosity "Configuration readed in " $ do
+    src <- StrictText.readFile dhallFilePath
+    parseAndCache dhallFilePath src
+
+
+parseAndCache :: FilePath -> StrictText.Text -> IO GenericPackageDescription 
+parseAndCache dhallFilePath src = do
+  ( hash, normExpr ) <- parseAndHash dhallFilePath src
+  cacheAndExtract hash normExpr dhallFilePath
+
+
+parseAndHash :: FilePath -> StrictText.Text
+             -> IO ( Crypto.Hash.Digest Crypto.Hash.SHA256
+                   , Dhall.Expr Dhall.Src Dhall.X
+                   ) 
+parseAndHash dhallFilePath src = do
+  let  settings = Dhall.defaultInputSettings
          & Lens.set Dhall.rootDirectory ( takeDirectory dhallFilePath )
          & Lens.set Dhall.sourceName dhallFilePath
-  fmap fixGPDConstraints $ dhallToCabal settings content
 
+  expr  <- Dhall.inputExprWithSettings settings src
+
+  let normExpr = Dhall.alphaNormalize expr
+      hash = Dhall.hashExpression Dhall.defaultStandardVersion normExpr
+
+  return ( hash, normExpr )
+
+
+cacheAndExtract :: Crypto.Hash.Digest Crypto.Hash.SHA256
+                -> Dhall.Expr Dhall.Src Dhall.X
+                -> FilePath
+                -> IO GenericPackageDescription
+cacheAndExtract hash normExpr dhallFilePath = do
+  gpd <- extract normExpr
+
+  writeDhallToCache hash normExpr
+  writeFileWithDhallHash hash dhallFilePath 
+
+  return gpd
+
+extract :: Dhall.Expr Dhall.Src Dhall.X -> IO GenericPackageDescription
+extract expr = do                                        
+  let Dhall.Type {..} = genericPackageDescription
+      annot = ( ( Dhall.Annot expr expected )
+                :: Dhall.Expr Dhall.Src Dhall.X )
+
+  _ <- throws ( Dhall.typeWith Dhall.Context.empty annot )
+
+  return $ fixGPDConstraints ( fromMaybe
+                               ( error "Empty extracted GenericPackageDescription" )
+                               ( extract expr ) )
+
+  where throws = either Control.Exception.throwIO return
+
+
+writeDhallToCache :: Crypto.Hash.Digest Crypto.Hash.SHA256
+                  -> Dhall.Expr Dhall.Src Dhall.X
+                  -> IO ()
+writeDhallToCache hash expr  = do
+  let status =
+        Lens.set
+          Dhall.Import.standardVersion
+          Dhall.defaultStandardVersion (Dhall.emptyStatus ".")
+      newImportHashed =
+        Dhall.ImportHashed
+          { Dhall.hash = Just hash
+          , Dhall.importType = Dhall.Missing
+          }
+      newImport =
+        Dhall.Import
+          { Dhall.importHashed = newImportHashed
+          , Dhall.importMode = Dhall.Code
+          }
+
+  State.evalStateT (Dhall.exprToImport newImport expr) status
+
+
+writeFileWithDhallHash :: Crypto.Hash.Digest Crypto.Hash.SHA256
+                       -> FilePath -> IO ()
+writeFileWithDhallHash hash dhallFilePath = do
+  path <- getFileWithDhallHashFilePath dhallFilePath
+
+  createDirectoryIfMissing True $ takeDirectory path
+  StrictText.writeFile path ( StrictText.pack ( show hash ) )  
+
+
+getFileWithDhallHashFilePath :: FilePath -> IO FilePath 
+getFileWithDhallHashFilePath dhallFilePath = do
+  let cacheDir = takeDirectory dhallFilePath </> "dist" </> "cache"
+
+  hashFileName <- getFileWithDhallHashFileName dhallFilePath
+  return $ cacheDir </> hashFileName
+
+
+getFileWithDhallHashFileName :: FilePath -> IO FilePath
+getFileWithDhallHashFileName dhallFilePath = do
+  canonPath <- canonicalizePath dhallFilePath
+
+  let hash = Hashable.hash canonPath
+
+  return $  showHex ( ( fromIntegral hash ) :: Word64 ) ""
+
 
 writeDerivedCabalFile :: Verbosity -> FilePath
-                      -> GenericPackageDescription -> IO FilePath
-writeDerivedCabalFile verbosity dir genPkg = do
-  let path = dir </> "etlas.dhall.cabal"
+                      -> GenericPackageDescription -> IO ()
+writeDerivedCabalFile verbosity path genPkg = do
   info verbosity $ "Writing derived cabal file from dhall file: " ++ path
+
+  let dir = takeDirectory path
+
   createDirectoryIfMissingVerbose verbosity True dir
   writeGenericPackageDescription path genPkg
-  return path
+
 
 -- TODO: Pick Lens modules from Cabal if we need them in more places
 condLibrary' :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library))

etlas/Distribution/Client/ProjectConfig.hs

@@ -1004,9 +1004,11 @@ readSourcePackage verbosity distDirLayout
 
 readSourcePackage verbosity _distDirLayout
   (ProjectPackageLocalDhallDirectory dir dhallFile) = do
-    monitorFiles [monitorFileHashed dhallFile]
     root <- askRoot
-    pkgdesc <- liftIO $ Dhall.readDhallGenericPackageDescription verbosity (root </> dhallFile)
+    let dhallPath = dhallFile
+        fileMonitorDhall = monitorFileHashed $ root </> dhallPath
+    monitorFiles [ fileMonitorDhall ]
+    pkgdesc <- liftIO $ Dhall.readAndCache verbosity dhallPath
     return $ SpecificSourcePackage SourcePackage {
       packageInfoId        = packageId pkgdesc,
       packageDescription   = pkgdesc,

etlas/Distribution/Client/SetupWrapper.hs

@@ -401,8 +401,9 @@ setupWrapper verbosity options mgenPkg mpkg cmd flags extraArgs = do
     if needDerivedCabalFile then do
       let distDir = useDistPref options
           dir = if isAbsolute distDir then distDir else currentDir </> distDir
+          cabalFilePath = dir </> "etlas.dhall.cabal"
           genPkg = setupGenericPackage setup
-      cabalFilePath <- writeDerivedCabalFile verbosity dir genPkg
+      writeDerivedCabalFile verbosity cabalFilePath genPkg
       absCabalFilePath <- makeAbsoluteToCwd cabalFilePath
       return ["--cabal-file", absCabalFilePath]
     else return []

etlas/Distribution/Client/Targets.hs

@@ -95,8 +95,9 @@ import Distribution.Simple.Utils
 import qualified Data.ByteString.Lazy.Char8 as BS.Char8
 #endif
 import Distribution.Client.PackageDescription.Dhall
-         ( readGenericPackageDescription, parseGenericPackageDescriptionFromDhall )
-
+         ( readGenericPackageDescription )
+import qualified Distribution.Client.PackageDescription.Dhall as PackageDescription.Dhall
+  ( parse )
 -- import Data.List ( find, nub )
 import Data.Either
          ( partitionEithers )
@@ -539,7 +540,7 @@ readPackageTarget verbosity = traverse modifyLocation
                              -> IO (Maybe GenericPackageDescription)
     parsePackageDescription' filePath content =
       if takeExtension filePath == ".dhall" 
-        then fmap Just $ parseGenericPackageDescriptionFromDhall filePath
+        then fmap Just $ PackageDescription.Dhall.parse filePath
                        $ StrictText.decodeUtf8 $ BS.toStrict content
         else return $
 #ifdef CABAL_PARSEC