Parser.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

module Dojang.Syntax.Manifest.Parser
  ( Error (..)
  , formatErrors
  , readManifest
  , readManifestFile
  ) where

import Data.Bifunctor (Bifunctor (first))
import Data.Either (lefts)
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty (toList)
import Data.String (IsString (fromString))
import Data.Void (Void)
import System.IO.Unsafe (unsafePerformIO)
import Prelude hiding (readFile)

import Data.HashMap.Strict as HashMap (fromList)
import Data.Map.Strict as Map (Map, empty, fromList, toList)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8Lenient)
import System.FilePattern (FilePattern)
import System.OsPath (OsPath, encodeFS)
import Toml (Result (..), decode)

import qualified Data.HashMap.Strict as HashMap
import Dojang.MonadFileSystem (FileType (..), MonadFileSystem (readFile))
import Dojang.Syntax.EnvironmentPredicate.Parser
  ( ParseErrorBundle
  , errorBundlePretty
  , parseEnvironmentPredicate
  )
import Dojang.Syntax.FilePathExpression.Parser
  ( errorBundlePretty
  , parseFilePathExpression
  )
import Dojang.Syntax.Manifest.Internal
  ( EnvironmentPredicate' (..)
  , FileRoute'
  , FileRouteMap'
  , FlatOrNonEmptyStrings (..)
  , Manifest' (..)
  , MonikerMap'
  )
import qualified Dojang.Syntax.Manifest.Internal as Internal
import Dojang.Types.EnvironmentPredicate
  ( EnvironmentPredicate (..)
  , normalizePredicate
  )
import Dojang.Types.FilePathExpression (FilePathExpression)
import Dojang.Types.FileRoute (FileRoute, fileRoute)
import Dojang.Types.FileRouteMap (FileRouteMap)
import Dojang.Types.Hook (Hook (..), HookMap, HookType (..))
import Dojang.Types.Manifest (Manifest (Manifest))
import Dojang.Types.MonikerMap (MonikerMap)
import Dojang.Types.MonikerName (MonikerName)


-- | An error made during parsing.
data Error
  = -- | TOML parsing errors.
    TomlErrors (NonEmpty String)
  | -- | An error made during parsing an 'EnvironmentPredicate'.
    EnvironmentPredicateError (ParseErrorBundle Text Void)
  | -- | An error made during parsing a 'FilePathExpression'.
    FilePathExpressionError (ParseErrorBundle Text Void)


-- | A warning message made during parsing.
type TomlWarning = Text


-- | Decodes a 'Manifest' from a 'Text'.
readManifest
  :: Text
  -- ^ A TOML document text to parse.
  -> Either Error (Manifest, [TomlWarning])
  -- ^ A decoded 'Manifest' with warnings, or a list of errors.
readManifest toml = case decode $ unpack toml of
  Success warnings manifest' ->
    case mapManifest manifest' of
      Left e -> Left e
      Right m -> Right (m, pack <$> warnings)
  Failure (e : es) -> Left $ TomlErrors $ e :| es
  Failure [] -> Left $ TomlErrors $ "unknown error" :| []


-- | Reads a 'Manifest' file from the given path.  It assumes that the file
-- is encoded in UTF-8.  Throws an 'IOError' if the file cannot be read.
readManifestFile
  :: (MonadFileSystem m)
  => OsPath
  -- ^ A path to the manifest file.
  -> m (Either Error (Manifest, [TomlWarning]))
  -- ^ A decoded manifest with warnings, or a list of errors.
readManifestFile filePath = do
  content <- readFile filePath
  return $ readManifest $ decodeUtf8Lenient content


-- | Format error messages.
formatErrors :: Error -> [Text]
formatErrors (TomlErrors es) = Data.List.NonEmpty.toList $ fmap pack es
formatErrors (EnvironmentPredicateError e) =
  [Dojang.Syntax.EnvironmentPredicate.Parser.errorBundlePretty e]
formatErrors (FilePathExpressionError e) =
  [Dojang.Syntax.FilePathExpression.Parser.errorBundlePretty e]


mapManifest :: Manifest' -> Either Error Manifest
mapManifest manifest' =
  case monikersResult of
    Left e -> Left e
    Right monikers' ->
      case mapFileRouteMap monikers' manifest'.dirs manifest'.files of
        Left e -> Left e
        Right fileRoutes' ->
          case mapHooks monikers' manifest'.hooks of
            Left e -> Left e
            Right hooks' ->
              Right $ Manifest monikers' fileRoutes' ignores' hooks'
 where
  monikersResult :: Either Error MonikerMap
  monikersResult = mapMonikerMap manifest'.monikers
  ignores' :: Map OsPath [FilePattern]
  ignores' =
    Map.fromList
      [ (encodePath path, pattern)
      | (path, pattern) <- Map.toList manifest'.ignores
      ]


mapMonikerMap :: MonikerMap' -> Either Error MonikerMap
mapMonikerMap m =
  case errors of
    e : _ -> Left e
    _ ->
      Right $
        HashMap.fromList
          [(name, pred') | (name, Right pred') <- results]
 where
  results :: [(MonikerName, Either Error EnvironmentPredicate)]
  results =
    [ (name, mapEnvironmentPredicate' pred')
    | (name, pred') <- toList m
    ]
  errors :: [Error]
  errors = lefts [r | (_, r) <- results]


mapEnvironmentPredicate'
  :: EnvironmentPredicate'
  -> Either Error EnvironmentPredicate
mapEnvironmentPredicate' envPred' =
  case when of
    Right pred' ->
      Right $
        normalizePredicate $
          And [os, arch, kernel, kernelRelease, all', any', pred']
    Left err -> Left err
 where
  os :: EnvironmentPredicate
  os =
    maybe
      Always
      (Or . fmap OperatingSystem . mapFlatOrNonEmptyStrings)
      envPred'.os
  arch :: EnvironmentPredicate
  arch =
    maybe
      Always
      (Or . fmap Architecture . mapFlatOrNonEmptyStrings)
      envPred'.arch
  kernel :: EnvironmentPredicate
  kernel =
    maybe
      Always
      (Or . fmap KernelName . mapFlatOrNonEmptyStrings)
      envPred'.kernel
  kernelRelease :: EnvironmentPredicate
  kernelRelease =
    maybe
      Always
      (Or . fmap KernelRelease . mapFlatOrNonEmptyStrings)
      envPred'.kernelRelease
  all' :: EnvironmentPredicate
  all' = maybe Always (And . fmap Moniker) envPred'.all
  any' :: EnvironmentPredicate
  any' = maybe Always (Or . fmap Moniker) envPred'.any
  when :: Either Error EnvironmentPredicate
  when =
    maybe
      (Right Always)
      (first EnvironmentPredicateError . parseEnvironmentPredicate "")
      envPred'.when


mapFlatOrNonEmptyStrings :: (IsString a) => FlatOrNonEmptyStrings -> NonEmpty a
mapFlatOrNonEmptyStrings (Flat a) = [fromString a]
mapFlatOrNonEmptyStrings (NonEmpty as) = fromString <$> as


mapFileRouteMap
  :: MonikerMap -> FileRouteMap' -> FileRouteMap' -> Either Error FileRouteMap
mapFileRouteMap monikerMap dirs files =
  case errors of
    e : _ -> Left e
    _ -> Right $ Map.fromList [(name, route) | (name, Right route) <- results]
 where
  results :: [(OsPath, Either Error FileRoute)]
  results =
    [ (encodePath name, mapFileRoute monikerMap route Directory)
    | (name, route) <- toList dirs
    ]
      ++ [ (encodePath name, mapFileRoute monikerMap route File)
         | (name, route) <- toList files
         ]
  errors :: [Error]
  errors = lefts [r | (_, r) <- results]


encodePath :: String -> OsPath
encodePath = unsafePerformIO . encodeFS


mapFileRoute
  :: MonikerMap
  -> FileRoute'
  -> FileType
  -> Either Error FileRoute
mapFileRoute monikerMap fileRoute' fileType =
  case errors of
    e : _ -> Left $ FilePathExpressionError e
    _ ->
      Right $
        fileRoute
          monikerMap
          ( [(name, Just expr') | (name, Just (Right expr')) <- results]
              ++ [(name, Nothing) | (name, Nothing) <- results]
          )
          fileType
 where
  results
    :: [ ( MonikerName
         , Maybe (Either (ParseErrorBundle Text Void) FilePathExpression)
         )
       ]
  results =
    [ ( name
      , if expr == "" then Nothing else Just $ parseFilePathExpression "" expr
      )
    | (name, expr) <- toList fileRoute'
    ]
  errors :: [ParseErrorBundle Text Void]
  errors = lefts [r | (_, Just r) <- results]


mapHooks :: MonikerMap -> Maybe Internal.Hooks' -> Either Error HookMap
mapHooks _ Nothing = Right Map.empty
mapHooks monikers (Just hooks') =
  case errors of
    e : _ -> Left e
    _ ->
      Right $
        Map.fromList
          [ (hookType, hookList)
          | (hookType, Right hookList) <- results
          , not (null hookList)
          ]
 where
  results :: [(HookType, Either Error [Hook])]
  results =
    [ (PreApply, mapHookList monikers hooks'.preApply)
    , (PreFirstApply, mapHookList monikers hooks'.preFirstApply)
    , (PostFirstApply, mapHookList monikers hooks'.postFirstApply)
    , (PostApply, mapHookList monikers hooks'.postApply)
    ]
  errors :: [Error]
  errors = lefts [r | (_, r) <- results]


mapHookList :: MonikerMap -> Maybe [Internal.Hook'] -> Either Error [Hook]
mapHookList _ Nothing = Right []
mapHookList monikers (Just hooks') =
  case errors of
    e : _ -> Left e
    _ -> Right [hook | Right hook <- results]
 where
  results :: [Either Error Hook]
  results = mapHook monikers <$> hooks'
  errors :: [Error]
  errors = lefts results


mapHook :: MonikerMap -> Internal.Hook' -> Either Error Hook
mapHook monikers hook' =
  case conditionResult of
    Left e -> Left e
    Right cond ->
      Right
        Hook
          { command = encodePath $ unpack hook'.command
          , args = maybe [] id hook'.args
          , condition = cond
          , workingDirectory = encodePath <$> hook'.workingDirectory
          , ignoreFailure = maybe False id hook'.ignoreFailure
          }
 where
  conditionResult :: Either Error EnvironmentPredicate
  conditionResult = case hook'.moniker of
    Just monikerName ->
      -- If moniker is specified, it takes precedence
      case HashMap.lookup monikerName monikers of
        Just pred' -> Right pred'
        Nothing -> Right $ Moniker monikerName
    Nothing ->
      -- Otherwise, parse the condition (when) field
      case hook'.condition of
        Nothing -> Right Always
        Just condText ->
          first EnvironmentPredicateError $
            parseEnvironmentPredicate "" condText