Dhall.hs

module Dhall.LSP.Backend.Dhall (
  FileIdentifier,
  fileIdentifierFromFilePath,
  fileIdentifierFromURI,
  hashNormalToCode,
  WellTyped,
  fromWellTyped,
  Normal,
  fromNormal,
  Cache,
  emptyCache,
  invalidate,
  DhallError(..),
  parse,
  parseWithHeader,
  load,
  typecheck,
  normalize
 ) where

import Dhall.Core   (Expr)
import Dhall.Parser (Src)

import Control.Exception                (SomeException, catch)
import Control.Lens                     (set, view)
import Control.Monad.Trans.State.Strict (runStateT)
import Data.Bifunctor                   (first)
import Data.List.NonEmpty               (NonEmpty ((:|)))
import Data.Text                        (Text)
import Data.Void                        (Void)
import Dhall                            (EvaluateSettings)
import Network.URI                      (URI)
import System.FilePath
    ( splitDirectories
    , takeDirectory
    , takeFileName
    )

import qualified Data.Graph                  as Graph
import qualified Data.Map.Strict             as Map
import qualified Data.Set                    as Set
import qualified Data.Text                   as Text
import qualified Dhall
import qualified Dhall.Core                  as Dhall
import qualified Dhall.Import                as Import
import qualified Dhall.Map
import qualified Dhall.Parser                as Dhall
import qualified Dhall.TypeCheck             as Dhall
import qualified Language.LSP.Protocol.Types as LSP.Types
import qualified Network.URI                 as URI


-- | A @FileIdentifier@ represents either a local file or a remote url.
newtype FileIdentifier = FileIdentifier Import.Chained

-- | Construct a FileIdentifier from a local file path.
fileIdentifierFromFilePath :: FilePath -> FileIdentifier
fileIdentifierFromFilePath path =
  let filename = Text.pack $ takeFileName path
      directory = takeDirectory path
      components = map Text.pack . reverse . splitDirectories $ directory
      file = Dhall.File (Dhall.Directory components) filename
  in FileIdentifier $ Import.chainedFromLocalHere Dhall.Absolute file Dhall.Code

-- | Construct a FileIdentifier from a given URI. Supports only "file:" URIs.
fileIdentifierFromURI :: URI -> Maybe FileIdentifier
fileIdentifierFromURI uri
  | URI.uriScheme uri == "file:" = do
    path <- LSP.Types.uriToFilePath . LSP.Types.Uri . Text.pack
                  $ URI.uriToString id uri ""
    return $ fileIdentifierFromFilePath path
fileIdentifierFromURI _ = Nothing

-- | A well-typed expression.
newtype WellTyped = WellTyped {fromWellTyped :: Expr Src Void}

-- | A fully normalised expression.
newtype Normal = Normal {fromNormal :: Expr Src Void}

-- An import graph, represented by list of import dependencies.
type ImportGraph = [Import.Depends]

-- | A cache maps Dhall imports to fully normalised expressions. By reusing
--   caches we can speeds up diagnostics etc. significantly!
data Cache = Cache ImportGraph (Dhall.Map.Map Import.Chained Import.ImportSemantics)

-- | The initial cache.
emptyCache :: Cache
emptyCache = Cache [] Dhall.Map.empty

-- | Invalidate any _unhashed_ imports of the given file. Hashed imports are
--   kept around as per
--   https://github.com/dhall-lang/dhall-lang/blob/master/standard/imports.md.
--   Transitively invalidates any imports depending on the changed file.
invalidate :: FileIdentifier -> Cache -> Cache
invalidate (FileIdentifier chained) (Cache dependencies cache) =
  Cache dependencies' $ Dhall.Map.withoutKeys cache invalidImports
  where
    imports = map Import.parent dependencies ++ map Import.child dependencies

    adjacencyLists = foldr
                       -- add reversed edges to adjacency lists
                       (\(Import.Depends parent child) -> Map.adjust (parent :) child)
                       -- starting from the discrete graph
                       (Map.fromList [ (i,[]) | i <- imports])
                       dependencies

    (graph, importFromVertex, vertexFromImport) = Graph.graphFromEdges
      [(node, node, neighbours) | (node, neighbours) <- Map.assocs adjacencyLists]

    -- compute the reverse dependencies, i.e. the imports reachable in the transposed graph
    reachableImports import_ =
      (map ((\ (i, _, _) -> i) . importFromVertex) . concat) $
        do vertex <- vertexFromImport import_
           return (Graph.reachable graph vertex)

    codeImport = Import.chainedChangeMode Dhall.Code chained
    textImport = Import.chainedChangeMode Dhall.RawText chained
    invalidImports = Set.fromList $ codeImport : reachableImports codeImport
                                    ++ textImport : reachableImports textImport

    dependencies' = filter (\(Import.Depends parent child) -> Set.notMember parent invalidImports
                                && Set.notMember child invalidImports) dependencies

-- | A Dhall error. Covers parsing, resolving of imports, typechecking and
--   normalisation.
data DhallError = ErrorInternal SomeException
                | ErrorImportSourced (Dhall.SourcedException Import.MissingImports)
                | ErrorTypecheck (Dhall.TypeError Src Void)
                | ErrorParse Dhall.ParseError

-- | Parse a Dhall expression.
parse :: Text -> Either DhallError (Expr Src Dhall.Import)
parse = fmap snd . parseWithHeader

-- | Parse a Dhall expression along with its "header", i.e. whitespace and
--   comments prefixing the actual code.
parseWithHeader :: Text -> Either DhallError (Dhall.Header, Expr Src Dhall.Import)
parseWithHeader = first ErrorParse . Dhall.exprAndHeaderFromText ""

-- | Resolve all imports in an expression.
load
    :: EvaluateSettings
    -> FileIdentifier
    -> Expr Src Dhall.Import
    -> Cache
    -> IO (Either DhallError (Cache, Expr Src Void))
load settings (FileIdentifier chained) expr (Cache graph cache) = do
  let emptyStatus =
             set Import.substitutions   (view Dhall.substitutions settings)
          .  set Import.normalizer      (view Dhall.normalizer settings)
          .  set Import.startingContext (view Dhall.startingContext settings)
          $ Import.emptyStatusWithManager (view Dhall.newManager settings) ""

  let status = -- reuse cache and import graph
               set Import.cache cache .
               set Import.graph graph .
               -- set "root import"
               set Import.stack (chained :| [])
                 $ emptyStatus
  (do (expr', status') <- runStateT (Import.loadWith expr) status
      let cache' = view Import.cache status'
          graph' = view Import.graph status'
      return . Right $ (Cache graph' cache', expr'))
    `catch` (\e -> return . Left $ ErrorImportSourced e)
    `catch` (\e -> return . Left $ ErrorInternal e)

-- | Typecheck a fully resolved expression. Returns a certification that the
--   input was well-typed along with its (well-typed) type.
typecheck
    :: EvaluateSettings
    -> Expr Src Void
    -> Either DhallError (WellTyped, WellTyped)
typecheck settings expr = case Dhall.typeWith (view Dhall.startingContext settings) expr of
  Left err -> Left $ ErrorTypecheck err
  Right typ -> Right (WellTyped expr, WellTyped typ)

-- | Normalise a well-typed expression.
normalize :: EvaluateSettings -> WellTyped -> Normal
normalize settings (WellTyped expr) = Normal $ Dhall.normalizeWith (view Dhall.normalizer settings) expr

-- | Given a normal expression compute the hash (using the default standard
--   version) of its alpha-normal form. Returns the hash in the format used in
--   Dhall's hash annotations (prefixed by "sha256:" and base-64 encoded).
hashNormalToCode :: Normal -> Text
hashNormalToCode (Normal expr) =
  Import.hashExpressionToCode (Dhall.denote alphaNormal)
  where alphaNormal = Dhall.alphaNormalize expr