module Dhall.LSP.Backend.Freezing (
  computeSemanticHash,
  getAllImportsWithHashPositions,
  getImportHashPosition,
  stripHash
) where

import Control.Lens                  (universeOf)
import Data.Text                     (Text)
import Dhall.Core
    ( Expr (..)
    , Import (..)
    , ImportHashed (..)
    , subExpressions
    )
import Dhall.LSP.Backend.Dhall
    ( Cache
    , DhallError
    , FileIdentifier
    , hashNormalToCode
    , load
    , normalize
    , typecheck
    )
import Dhall.LSP.Backend.Diagnostics
    ( Range (..)
    , positionFromMegaparsec
    , positionToOffset
    , rangeFromDhall
    , subtractPosition
    )
import Dhall.LSP.Backend.Parsing     (getImportHash)
import Dhall.Parser                  (Src (..))


import qualified Data.Text as Text

-- | Given an expression (potentially still containing imports) compute its
-- 'semantic' hash in the textual representation used to freeze Dhall imports.
computeSemanticHash :: FileIdentifier -> Expr Src Import -> Cache ->
  IO (Either DhallError (Cache, Text))
computeSemanticHash :: FileIdentifier
-> Expr Src Import -> Cache -> IO (Either DhallError (Cache, Text))
computeSemanticHash FileIdentifier
fileid Expr Src Import
expr Cache
cache = do
  Either DhallError (Cache, Expr Src Void)
loaded <- FileIdentifier
-> Expr Src Import
-> Cache
-> IO (Either DhallError (Cache, Expr Src Void))
load FileIdentifier
fileid Expr Src Import
expr Cache
cache
  case Either DhallError (Cache, Expr Src Void)
loaded of
    Left DhallError
err -> Either DhallError (Cache, Text)
-> IO (Either DhallError (Cache, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (DhallError -> Either DhallError (Cache, Text)
forall a b. a -> Either a b
Left DhallError
err)
    Right (Cache
cache', Expr Src Void
expr') -> case Expr Src Void -> Either DhallError (WellTyped, WellTyped)
typecheck Expr Src Void
expr' of
      Left DhallError
err -> Either DhallError (Cache, Text)
-> IO (Either DhallError (Cache, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (DhallError -> Either DhallError (Cache, Text)
forall a b. a -> Either a b
Left DhallError
err)
      Right (WellTyped
wt,WellTyped
_) ->
        Either DhallError (Cache, Text)
-> IO (Either DhallError (Cache, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Cache, Text) -> Either DhallError (Cache, Text)
forall a b. b -> Either a b
Right (Cache
cache', Normal -> Text
hashNormalToCode (WellTyped -> Normal
normalize WellTyped
wt)))

stripHash :: Import -> Import
stripHash :: Import -> Import
stripHash (Import (ImportHashed Maybe SHA256Digest
_ ImportType
importType) ImportMode
mode) =
  ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed Maybe SHA256Digest
forall a. Maybe a
Nothing ImportType
importType) ImportMode
mode

getImportHashPosition :: Src -> Maybe Range
getImportHashPosition :: Src -> Maybe Range
getImportHashPosition src :: Src
src@(Src SourcePos
left SourcePos
_ Text
text)  = do
  Src SourcePos
left' SourcePos
right' Text
_ <- Src -> Maybe Src
getImportHash Src
src
  let p0 :: Position
p0 = SourcePos -> Position
positionFromMegaparsec SourcePos
left

  -- sanitise the starting point
  let p1 :: Position
p1 = SourcePos -> Position
positionFromMegaparsec SourcePos
left'
      off1 :: Int
off1 = Text -> Position -> Int
positionToOffset Text
text (Position -> Position -> Position
subtractPosition Position
p0 Position
p1)
      Range Position
_ Position
left'' = Src -> Range
rangeFromDhall (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
left SourcePos
left' (Int -> Text -> Text
Text.take Int
off1 Text
text))

  -- sanitise the end point
  let Range Position
_ Position
right'' = Src -> Range
rangeFromDhall (SourcePos -> SourcePos -> Text -> Src
Src SourcePos
left SourcePos
right' Text
text)

  Range -> Maybe Range
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> Position -> Range
Range Position
left'' Position
right'')

getAllImportsWithHashPositions :: Expr Src Import -> [(Import, Range)]
getAllImportsWithHashPositions :: Expr Src Import -> [(Import, Range)]
getAllImportsWithHashPositions Expr Src Import
expr =
  [ (Import
i, Range
range) |
    Note Src
src (Embed Import
i) <- Getting [Expr Src Import] (Expr Src Import) (Expr Src Import)
-> Expr Src Import -> [Expr Src Import]
forall a. Getting [a] a a -> a -> [a]
universeOf Getting [Expr Src Import] (Expr Src Import) (Expr Src Import)
forall (f :: * -> *) s a.
Applicative f =>
(Expr s a -> f (Expr s a)) -> Expr s a -> f (Expr s a)
subExpressions Expr Src Import
expr,
    Just Range
range <- [Src -> Maybe Range
getImportHashPosition Src
src] ]