Resolution.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

module Caliper.Syntax.Resolution where

import Control.Monad
import Control.Monad.Trans.State.Strict
import Data.Either
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Void
import GHC.Generics
import Text.Megaparsec hiding (ParseError, State)

import Caliper.Syntax.Ast
import Caliper.Syntax.Parsing
import Caliper.Syntax.Position

-- | Necessary information to emit a helpful error
data ResolutionError = ResolutionError ResolutionErrorKind SrcSpan
  deriving (Show, Generic)

data ResolutionErrorKind
  = -- | fail when time span is negative
    NegativeTimeSpan NominalDiffTime
  | InvalidTime T.Text
  | UndeclaredType T.Text
  | DuplicatedType T.Text T.Text
  deriving (Show, Generic)

data ResolveState = ResolveState
  { rsTimezone :: Maybe TimeZone
  -- ^ Timezone as it was last seen
  }
initialResolveState :: ResolveState
initialResolveState =
  ResolveState
    { rsTimezone = Nothing
    }

type ResolveResult = ([ResolutionError], [ResolvedEntry])

parseAndResolve
  :: FilePath
  -> IO
       ( T.Text
       , Either (ParseErrorBundle T.Text Void) ResolveResult
       )
parseAndResolve filepath = do
  content <- TIO.readFile filepath
  let parsedRes = runParser caliperAst filepath content
  pure
    ( content
    , resolve <$> parsedRes
    )

resolve :: RawAst -> ResolveResult
resolve ast = evalState (resolve' ast) initialResolveState

resolve' :: RawAst -> State ResolveState ResolveResult
resolve' ast = fmap sortResolvedEntriesAbsolute . mconcat <$> traverse go (rawAstEntriesOrTZ ast)
  where
    go (RawEntries es) = do
      maybeTZ <- gets rsTimezone
      pure $ resolveEntries (rawAstTypeDecls ast) maybeTZ es
    go (TZDecl tzStr) = do
      put ResolveState {rsTimezone = Just tzStr}
      pure mempty

sortResolvedEntriesAbsolute :: [ResolvedEntry] -> [ResolvedEntry]
sortResolvedEntriesAbsolute = sortOn (zonedTimeToUTC . entryStart)

-- | Postcondition: the entries are sortied
resolveEntries
  :: [T.Text]
  -> Maybe TimeZone
  -> [RawEntry]
  -> ([ResolutionError], [ResolvedEntry])
resolveEntries typeDeclarations maybeTZ =
  partitionEithers . map (resolveEntry typeDeclarations maybeTZ)

-- TODO: maybe add a warning for zero spans?
resolveEntry
  :: [T.Text]
  -> Maybe TimeZone
  -> RawEntry
  -> Either ResolutionError ResolvedEntry
resolveEntry typeDeclarations maybeTZ (RawEntry {..}) = do
  let spn :: NominalDiffTime
      spn = fst rawEntryEnd `diffLocalTime` rawEntryStart
  when (spn <= 0) $
    Left $
      ResolutionError (NegativeTimeSpan spn) (snd rawEntryEnd)
  tagOk <- checkTypeUnicity rawEntryMetadata

  ResolvedEntry
    <$> (toZonedTime rawEntryStart)
    <*> (toZonedTime $ fst rawEntryEnd)
    <*> (pure (fmap fst <$> tagOk))
  where
    checkTypeUnicity
      :: M.Map T.Text (NE.NonEmpty (T.Text, SrcSpan))
      -> Either ResolutionError (M.Map T.Text (NE.NonEmpty (T.Text, SrcSpan)))
    checkTypeUnicity m = case m M.!? "type" of
      Nothing -> Right m
      Just types -> case types of
        (ty, pos) NE.:| [] ->
          if (not . null) typeDeclarations -- If no type is declared, disable undeclared type checking
            && ty `elem` typeDeclarations
            then Right m
            else Left $ ResolutionError (UndeclaredType ty) pos
        (ty, _) NE.:| ((ty2, pos2) : _) -> Left $ ResolutionError (DuplicatedType ty ty2) pos2

    toZonedTime :: LocalTime -> Either ResolutionError ZonedTime
    toZonedTime t = pure $ ZonedTime t (fromMaybe utc maybeTZ) -- TODO: make an error for this?