{-# LANGUAGE CPP
           , DataKinds
           , OverloadedStrings
           , FlexibleContexts
           #-}
module Language.Hakaru.Command where

import           Language.Hakaru.Syntax.ABT
import qualified Language.Hakaru.Syntax.AST as T
import           Language.Hakaru.Parser.Import (expandImports)
import           Language.Hakaru.Parser.Parser (parseHakaru, parseHakaruWithImports)
import           Language.Hakaru.Parser.SymbolResolve (resolveAST)
import           Language.Hakaru.Syntax.TypeCheck

import           Control.Monad.Trans.Except
import           Control.Monad (when)
import qualified Data.Text      as Text
import qualified Data.Text.IO   as IO
import qualified Data.Text.Utf8 as U
import qualified Options.Applicative as O
import           Data.Vector
import           System.IO (stderr)
import           System.Environment (getArgs)
import           Data.Monoid ((<>),mconcat)
import           System.FilePath (takeDirectory)

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative   (Applicative(..), (<$>))
#endif

type Term a = TrivialABT T.Term '[] a

parseAndInfer :: Text.Text
              -> Either Text.Text (TypedAST (TrivialABT T.Term))
parseAndInfer :: Text -> Either Text (TypedAST (TrivialABT Term))
parseAndInfer Text
x = Text -> TypeCheckMode -> Either Text (TypedAST (TrivialABT Term))
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Text -> TypeCheckMode -> Either Text (TypedAST abt)
parseAndInferWithMode Text
x TypeCheckMode
LaxMode

parseAndInferWithMode
  :: ABT T.Term abt
  => Text.Text
  -> TypeCheckMode
  -> Either Text.Text (TypedAST abt)
parseAndInferWithMode :: Text -> TypeCheckMode -> Either Text (TypedAST abt)
parseAndInferWithMode Text
x TypeCheckMode
mode =
    case Text -> Either ParseError (AST' Text)
parseHakaru Text
x of
    Left  ParseError
err  -> Text -> Either Text (TypedAST abt)
forall a b. a -> Either a b
Left (String -> Text
Text.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show (ParseError -> Text) -> ParseError -> Text
forall a b. (a -> b) -> a -> b
$ ParseError
err)
    Right AST' Text
past ->
        let m :: TypeCheckMonad (TypedAST abt)
m = AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType (AST' Text -> AST
resolveAST AST' Text
past) in
        TypeCheckMonad (TypedAST abt)
-> Input -> TypeCheckMode -> Either Text (TypedAST abt)
forall a.
TypeCheckMonad a -> Input -> TypeCheckMode -> Either Text a
runTCM TypeCheckMonad (TypedAST abt)
m (Text -> Input
splitLines Text
x) TypeCheckMode
mode

-- The filepath from which the text came and the text itself. If the filepath is
-- Nothing, imports are searched for in the current directory.
data Source = Source { Source -> Maybe String
file :: Maybe FilePath, Source -> Text
source :: Text.Text }

sourceInput :: Source -> Maybe (Vector Text.Text)
sourceInput :: Source -> Input
sourceInput = Text -> Input
splitLines (Text -> Input) -> (Source -> Text) -> Source -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Source -> Text
source

noFileSource :: Text.Text -> Source
noFileSource :: Text -> Source
noFileSource = Maybe String -> Text -> Source
Source Maybe String
forall a. Maybe a
Nothing

fileSource :: FilePath -> Text.Text -> Source
fileSource :: String -> Text -> Source
fileSource = Maybe String -> Text -> Source
Source (Maybe String -> Text -> Source)
-> (String -> Maybe String) -> String -> Text -> Source
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just

parseAndInfer' :: Source
               -> IO (Either Text.Text (TypedAST (TrivialABT T.Term)))
parseAndInfer' :: Source -> IO (Either Text (TypedAST (TrivialABT Term)))
parseAndInfer' Source
s = Source
-> TypeCheckMode -> IO (Either Text (TypedAST (TrivialABT Term)))
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
Source -> TypeCheckMode -> IO (Either Text (TypedAST abt))
parseAndInferWithMode' Source
s TypeCheckMode
LaxMode

parseAndInferWithMode'
  :: ABT T.Term abt
  => Source
  -> TypeCheckMode
  -> IO (Either Text.Text (TypedAST abt))
parseAndInferWithMode' :: Source -> TypeCheckMode -> IO (Either Text (TypedAST abt))
parseAndInferWithMode' (Source Maybe String
dir Text
x) TypeCheckMode
mode =
    case Text -> Either ParseError (ASTWithImport' Text)
parseHakaruWithImports Text
x of
    Left  ParseError
err  -> Either Text (TypedAST abt) -> IO (Either Text (TypedAST abt))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (TypedAST abt) -> IO (Either Text (TypedAST abt)))
-> (Text -> Either Text (TypedAST abt))
-> Text
-> IO (Either Text (TypedAST abt))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (TypedAST abt)
forall a b. a -> Either a b
Left (Text -> IO (Either Text (TypedAST abt)))
-> Text -> IO (Either Text (TypedAST abt))
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show (ParseError -> Text) -> ParseError -> Text
forall a b. (a -> b) -> a -> b
$ ParseError
err
    Right ASTWithImport' Text
past -> do
      Either ParseError (AST' Text)
past' <- ExceptT ParseError IO (AST' Text)
-> IO (Either ParseError (AST' Text))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Maybe String
-> ASTWithImport' Text -> ExceptT ParseError IO (AST' Text)
expandImports ((String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
takeDirectory Maybe String
dir) ASTWithImport' Text
past)
      case Either ParseError (AST' Text)
past' of
        Left ParseError
err     -> Either Text (TypedAST abt) -> IO (Either Text (TypedAST abt))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (TypedAST abt) -> IO (Either Text (TypedAST abt)))
-> (Text -> Either Text (TypedAST abt))
-> Text
-> IO (Either Text (TypedAST abt))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (TypedAST abt)
forall a b. a -> Either a b
Left (Text -> IO (Either Text (TypedAST abt)))
-> Text -> IO (Either Text (TypedAST abt))
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show (ParseError -> Text) -> ParseError -> Text
forall a b. (a -> b) -> a -> b
$ ParseError
err
        Right AST' Text
past'' -> do
          let m :: TypeCheckMonad (TypedAST abt)
m = AST -> TypeCheckMonad (TypedAST abt)
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType (AST' Text -> AST
resolveAST AST' Text
past'')
          Either Text (TypedAST abt) -> IO (Either Text (TypedAST abt))
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeCheckMonad (TypedAST abt)
-> Input -> TypeCheckMode -> Either Text (TypedAST abt)
forall a.
TypeCheckMonad a -> Input -> TypeCheckMode -> Either Text a
runTCM TypeCheckMonad (TypedAST abt)
m (Text -> Input
splitLines Text
x) TypeCheckMode
mode)

parseAndInferWithDebug
    :: Bool
    -> Text.Text
    -> IO (Either Text.Text (TypedAST (TrivialABT T.Term)))
parseAndInferWithDebug :: Bool -> Text -> IO (Either Text (TypedAST (TrivialABT Term)))
parseAndInferWithDebug Bool
debug Text
x =
  case Text -> Either ParseError (AST' Text)
parseHakaru Text
x of
    Left ParseError
err -> Either Text (TypedAST (TrivialABT Term))
-> IO (Either Text (TypedAST (TrivialABT Term)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (TypedAST (TrivialABT Term))
 -> IO (Either Text (TypedAST (TrivialABT Term))))
-> Either Text (TypedAST (TrivialABT Term))
-> IO (Either Text (TypedAST (TrivialABT Term)))
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (TypedAST (TrivialABT Term))
forall a b. a -> Either a b
Left (String -> Text
Text.pack (String -> Text) -> (ParseError -> String) -> ParseError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show (ParseError -> Text) -> ParseError -> Text
forall a b. (a -> b) -> a -> b
$ ParseError
err)
    Right AST' Text
past -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putErrorLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
hrule Text
"Parsed AST"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putErrorLn (Text -> IO ()) -> (AST' Text -> Text) -> AST' Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (AST' Text -> String) -> AST' Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AST' Text -> String
forall a. Show a => a -> String
show (AST' Text -> IO ()) -> AST' Text -> IO ()
forall a b. (a -> b) -> a -> b
$ AST' Text
past
      let resolved :: AST
resolved = AST' Text -> AST
resolveAST AST' Text
past
      let inferred :: Either Text (TypedAST (TrivialABT Term))
inferred  = TypeCheckMonad (TypedAST (TrivialABT Term))
-> Input
-> TypeCheckMode
-> Either Text (TypedAST (TrivialABT Term))
forall a.
TypeCheckMonad a -> Input -> TypeCheckMode -> Either Text a
runTCM (AST -> TypeCheckMonad (TypedAST (TrivialABT Term))
forall (abt :: [Hakaru] -> Hakaru -> *).
ABT Term abt =>
AST -> TypeCheckMonad (TypedAST abt)
inferType AST
resolved) (Text -> Input
splitLines Text
x) TypeCheckMode
LaxMode
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putErrorLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
hrule Text
"Inferred AST"
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
putErrorLn (Text -> IO ())
-> (Either Text (TypedAST (TrivialABT Term)) -> Text)
-> Either Text (TypedAST (TrivialABT Term))
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (Either Text (TypedAST (TrivialABT Term)) -> String)
-> Either Text (TypedAST (TrivialABT Term))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text (TypedAST (TrivialABT Term)) -> String
forall a. Show a => a -> String
show (Either Text (TypedAST (TrivialABT Term)) -> IO ())
-> Either Text (TypedAST (TrivialABT Term)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Either Text (TypedAST (TrivialABT Term))
inferred
      Either Text (TypedAST (TrivialABT Term))
-> IO (Either Text (TypedAST (TrivialABT Term)))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text (TypedAST (TrivialABT Term))
 -> IO (Either Text (TypedAST (TrivialABT Term))))
-> Either Text (TypedAST (TrivialABT Term))
-> IO (Either Text (TypedAST (TrivialABT Term)))
forall a b. (a -> b) -> a -> b
$ Either Text (TypedAST (TrivialABT Term))
inferred
  where hrule :: Text -> Text
hrule Text
s = [Text] -> Text
Text.concat [Text
"\n<=======================| "
                              ,Text
s,Text
" |=======================>\n"]
        putErrorLn :: Text -> IO ()
putErrorLn = Handle -> Text -> IO ()
IO.hPutStrLn Handle
stderr


splitLines :: Text.Text -> Maybe (Vector Text.Text)
splitLines :: Text -> Input
splitLines = Vector Text -> Input
forall a. a -> Maybe a
Just (Vector Text -> Input) -> (Text -> Vector Text) -> Text -> Input
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Vector Text
forall a. [a] -> Vector a
fromList ([Text] -> Vector Text) -> (Text -> [Text]) -> Text -> Vector Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines

readFromFile :: String -> IO Text.Text
readFromFile :: String -> IO Text
readFromFile String
"-" = IO Text
U.getContents
readFromFile String
x   = String -> IO Text
U.readFile String
x

readFromFile' :: String -> IO Source
readFromFile' :: String -> IO Source
readFromFile' String
x = Maybe String -> Text -> Source
Source (if String
xString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"-" then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
x) (Text -> Source) -> IO Text -> IO Source
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Text
readFromFile String
x

simpleCommand :: (Text.Text -> IO ()) -> Text.Text -> IO ()
simpleCommand :: (Text -> IO ()) -> Text -> IO ()
simpleCommand Text -> IO ()
k Text
fnName = 
  let parser :: ParserInfo String
parser = 
        Parser String -> InfoMod String -> ParserInfo String
forall a. Parser a -> InfoMod a -> ParserInfo a
O.info (Parser (String -> String)
forall a. Parser (a -> a)
O.helper Parser (String -> String) -> Parser String -> Parser String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String
opts)
               (InfoMod String
forall a. InfoMod a
O.fullDesc InfoMod String -> InfoMod String -> InfoMod String
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod String
forall a. String -> InfoMod a
O.progDesc 
                 ([String] -> String
forall a. Monoid a => [a] -> a
mconcat[String
"Hakaru:", Text -> String
Text.unpack Text
fnName, String
" command"]))
      opts :: Parser String
opts = 
        Mod ArgumentFields String -> Parser String
forall s. IsString s => Mod ArgumentFields s -> Parser s
O.strArgument
           ( String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
O.metavar String
"PROGRAM" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> 
             Mod ArgumentFields String
forall a (f :: * -> *). Show a => Mod f a
O.showDefault Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
O.value String
"-" Mod ArgumentFields String
-> Mod ArgumentFields String -> Mod ArgumentFields String
forall a. Semigroup a => a -> a -> a
<> 
             String -> Mod ArgumentFields String
forall (f :: * -> *) a. String -> Mod f a
O.help String
"Filepath to Hakaru program OR \"-\"" )

  in ParserInfo String -> IO String
forall a. ParserInfo a -> IO a
O.execParser ParserInfo String
parser IO String -> (String -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO Text
readFromFile IO Text -> (Text -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> IO ()
k 

writeToFile :: String -> (Text.Text -> IO ())
writeToFile :: String -> Text -> IO ()
writeToFile String
"-" = Text -> IO ()
U.putStrLn 
writeToFile String
x   = String -> Text -> IO ()
U.writeFile String
x