{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

module Rzk.Main where

import           Control.Monad        (forM, when)
import           Data.List            (sort)
import qualified Data.Yaml            as Yaml
import           System.Directory     (doesPathExist)
import           System.FilePath.Glob (glob)

import qualified Language.Rzk.Syntax  as Rzk
import           Rzk.Project.Config
import           Rzk.TypeCheck



parseStdin :: IO Rzk.Module
parseStdin :: IO Module
parseStdin = do
  Either String Module
result <- String -> Either String Module
Rzk.parseModule (String -> Either String Module)
-> IO String -> IO (Either String Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getContents
  case Either String Module
result of
    Left String
err -> do
      String -> IO ()
putStrLn (String
"An error occurred when parsing stdin")
      String -> IO Module
forall a. HasCallStack => String -> a
error String
err
    Right Module
rzkModule -> Module -> IO Module
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Module
rzkModule

-- | Finds matches to the given pattern in the current working directory.
-- **NOTE:** throws exception when 'glob' returns an empty list.
globNonEmpty :: FilePath -> IO [FilePath]
globNonEmpty :: String -> IO [String]
globNonEmpty String
path = do
  String -> IO [String]
glob String
path IO [String] -> ([String] -> IO [String]) -> IO [String]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    []    -> String -> IO [String]
forall a. HasCallStack => String -> a
error (String
"File(s) not found at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path)
    [String]
paths -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
paths)

extractFilesFromRzkYaml :: FilePath -> IO [FilePath]
extractFilesFromRzkYaml :: String -> IO [String]
extractFilesFromRzkYaml String
rzkYamlPath = do
  Either ParseException ProjectConfig
eitherConfig <- forall a. FromJSON a => String -> IO (Either ParseException a)
Yaml.decodeFileEither @ProjectConfig String
rzkYamlPath
  case Either ParseException ProjectConfig
eitherConfig of
    Left ParseException
err -> do
      String -> IO [String]
forall a. HasCallStack => String -> a
error (String
"Invalid or missing rzk.yaml: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseException -> String
Yaml.prettyPrintParseException ParseException
err)
    Right ProjectConfig{[String]
include :: [String]
exclude :: [String]
exclude :: ProjectConfig -> [String]
include :: ProjectConfig -> [String]
..} -> do
      [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
include

-- | Given a list of file paths (possibly including globs), expands the globs (if any)
-- or tries to read the list of files from the rzk.yaml file (if no paths are given).
-- Glob patterns in rzk.yaml are also expanded.
expandRzkPathsOrYaml :: [FilePath] -> IO [FilePath]
expandRzkPathsOrYaml :: [String] -> IO [String]
expandRzkPathsOrYaml = \case
    [] -> do
      let rzkYamlPath :: String
rzkYamlPath = String
"rzk.yaml"
      Bool
rzkYamlExists <- String -> IO Bool
doesPathExist String
rzkYamlPath
      if Bool
rzkYamlExists
        then do
          [String]
paths <- String -> IO [String]
extractFilesFromRzkYaml String
rzkYamlPath
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
paths) (String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No files found in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rzkYamlPath)
          [String] -> IO [String]
expandRzkPathsOrYaml [String]
paths
        else String -> IO [String]
forall a. HasCallStack => String -> a
error (String
"No paths given and no " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rzkYamlPath String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" found")
    [String]
paths -> (String -> IO [String]) -> [String] -> IO [String]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> IO [String]
globNonEmpty [String]
paths

parseRzkFilesOrStdin :: [FilePath] -> IO [(FilePath, Rzk.Module)]
parseRzkFilesOrStdin :: [String] -> IO [(String, Module)]
parseRzkFilesOrStdin = \case
  -- if no paths are given — read from stdin
  -- TODO: reuse the `expandRzkPathsOrYaml` function
  [] -> do
    let rzkYamlPath :: String
rzkYamlPath = String
"rzk.yaml"
    Bool
rzkYamlExists <- String -> IO Bool
doesPathExist String
rzkYamlPath
    if Bool
rzkYamlExists
      then do
        String -> IO ()
putStrLn (String
"Using Rzk project stucture specified in " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rzkYamlPath)
        [String]
paths <- String -> IO [String]
extractFilesFromRzkYaml String
rzkYamlPath
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
paths) (String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"No Rzk files specified in the config file at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rzkYamlPath)
        [String] -> IO [(String, Module)]
parseRzkFilesOrStdin [String]
paths
      else do
        Module
rzkModule <- IO Module
parseStdin
        [(String, Module)] -> IO [(String, Module)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String
"<stdin>", Module
rzkModule)]
  -- otherwise — parse all given files in given order
  [String]
paths -> do
    [String]
expandedPaths <- (String -> IO [String]) -> [String] -> IO [String]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> IO [String]
globNonEmpty [String]
paths
    [String]
-> (String -> IO (String, Module)) -> IO [(String, Module)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
expandedPaths ((String -> IO (String, Module)) -> IO [(String, Module)])
-> (String -> IO (String, Module)) -> IO [(String, Module)]
forall a b. (a -> b) -> a -> b
$ \String
path -> do
      String -> IO ()
putStrLn (String
"Loading file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path)
      Either String Module
result <- String -> Either String Module
Rzk.parseModule (String -> Either String Module)
-> IO String -> IO (Either String Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path
      case Either String Module
result of
        Left String
err -> do
          String -> IO ()
putStrLn (String
"An error occurred when parsing file " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path)
          String -> IO (String, Module)
forall a. HasCallStack => String -> a
error String
err
        Right Module
rzkModule -> (String, Module) -> IO (String, Module)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
path, Module
rzkModule)

typecheckString :: String -> Either String String
typecheckString :: String -> Either String String
typecheckString String
moduleString = do
  Module
rzkModule <- String -> Either String Module
Rzk.parseModule String
moduleString
  case TypeCheck VarIdent [Decl']
-> Either (TypeErrorInScopedContext VarIdent) [Decl']
forall var a.
TypeCheck var a -> Either (TypeErrorInScopedContext var) a
defaultTypeCheck ([Module] -> TypeCheck VarIdent [Decl']
typecheckModules [Module
rzkModule]) of
    Left TypeErrorInScopedContext VarIdent
err -> String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
      [ String
"An error occurred when typechecking!"
      , String
"Rendering type error... (this may take a few seconds)"
      , [String] -> String
unlines
        [ String
"Type Error:"
        , OutputDirection -> TypeErrorInScopedContext VarIdent -> String
ppTypeErrorInScopedContext' OutputDirection
BottomUp TypeErrorInScopedContext VarIdent
err
        ]
      ]
    Right [Decl']
_ -> String -> Either String String
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Everything is ok!"