{-# LANGUAGE OverloadedStrings #-}

-- | Main module for the library
module Language.ATS ( -- * Functions for working with syntax
                      lexATS
                    , parse
                    , parseWithCtx
                    , parseM
                    , printATS
                    , printATSCustom
                    , printATSFast
                    , printErr
                    , warnErr
                    , defaultFixityState
                    -- * Library functions
                    , getDependencies
                    , getDependenciesC
                    -- * Syntax Tree
                    , ATS (..)
                    , Declaration (..)
                    , Expression (..)
                    , Type (..)
                    , Function (..)
                    , Implementation (..)
                    , Pattern (..)
                    , Name (..)
                    , UnOp (..)
                    , BinOp (..)
                    , DataPropLeaf (..)
                    , Leaf (..)
                    , DataSortLeaf (..)
                    , Arg (..)
                    , Addendum (..)
                    , LambdaType (..)
                    , Universal (..)
                    , Existential (..)
                    , PreFunction (..)
                    , StaticExpression (..)
                    , StackFunction (..)
                    , Fixity (..)
                    , SortArg (..)
                    , Sort (..)
                    , SortArgs
                    , Args
                    , Fix
                    -- * Parser State
                    , FixityState
                    -- * Lexical types
                    , Token (..)
                    , AlexPosn (..)
                    , Keyword (..)
                    -- * Error types
                    , ATSError (..)
                    -- * Lenses
                    , preF
                    , expression
                    , fun
                    , leaves
                    , constructorUniversals
                    , typeCall
                    , typeCallArgs
                    -- * Misecellany
                    , languageATSVersion
                    ) where

import           Control.Composition          ((-$))
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.State
import           Data.Version                 (Version)
import           GHC.IO.Handle.FD             (stderr)
import           Language.ATS.Lexer
import           Language.ATS.Parser
import           Language.ATS.PrettyPrint
import           Language.ATS.Rewrite
import           Language.ATS.Types
import           Language.ATS.Types.Lens
import           Lens.Micro
import           Paths_language_ats           (version)
import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>))

-- | @since 1.7.4.0
languageATSVersion :: Version
languageATSVersion :: Version
languageATSVersion = Version
version

rewriteATS' :: Eq a => (ATS a, FixityState a) -> ATS a
rewriteATS' :: (ATS a, FixityState a) -> ATS a
rewriteATS' (ATS [Declaration a]
ds, FixityState a
st) = [Declaration a] -> ATS a
forall a. [Declaration a] -> ATS a
ATS (FixityState a -> Declaration a -> Declaration a
forall a. Eq a => FixityState a -> Declaration a -> Declaration a
rewriteDecl FixityState a
st (Declaration a -> Declaration a)
-> [Declaration a] -> [Declaration a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration a]
ds)

-- | Print an error message to standard error.
printErr :: MonadIO m => ATSError -> m ()
printErr :: ATSError -> m ()
printErr = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ATSError -> IO ()) -> ATSError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Doc -> IO ()
hPutDoc Handle
stderr (Doc -> IO ()) -> (ATSError -> Doc) -> ATSError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n") (Doc -> Doc) -> (ATSError -> Doc) -> ATSError -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATSError -> Doc
forall a. Pretty a => a -> Doc
pretty

-- | Same as 'printErr', but print a yellow warning message instead.
warnErr :: MonadIO m => FilePath -> ATSError -> m ()
warnErr :: FilePath -> ATSError -> m ()
warnErr FilePath
fp = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ATSError -> IO ()) -> ATSError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Doc -> IO ()
hPutDoc Handle
stderr (Doc -> IO ()) -> (ATSError -> Doc) -> ATSError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Doc -> Doc
dullyellow Doc
"Warning" Doc -> Doc -> Doc
<+> FilePath -> Doc
text (FilePath
fp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":")) Doc -> Doc -> Doc
<+> ) (Doc -> Doc) -> (ATSError -> Doc) -> ATSError -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATSError -> Doc
preErr
-- TODO: this should detect if being piped to terminal!

-- | Parse a string containing ATS source, disregarding comments.
parseM :: String -> Either ATSError (ATS AlexPosn)
parseM :: FilePath -> Either ATSError (ATS AlexPosn)
parseM = FixityState AlexPosn
-> ([Token] -> [Token])
-> FilePath
-> Either ATSError (ATS AlexPosn)
parseWithCtx FixityState AlexPosn
forall a. FixityState a
defaultFixityState [Token] -> [Token]
stripComments

-- | Parse a string containing ATS source.
parse :: String -> Either ATSError (ATS AlexPosn)
parse :: FilePath -> Either ATSError (ATS AlexPosn)
parse = FixityState AlexPosn
-> ([Token] -> [Token])
-> FilePath
-> Either ATSError (ATS AlexPosn)
parseWithCtx FixityState AlexPosn
forall a. FixityState a
defaultFixityState [Token] -> [Token]
forall a. a -> a
id

lexErr :: Either String a -> Either ATSError a
lexErr :: Either FilePath a -> Either ATSError a
lexErr = ASetter (Either FilePath a) (Either ATSError a) FilePath ATSError
-> (FilePath -> ATSError) -> Either FilePath a -> Either ATSError a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Either FilePath a) (Either ATSError a) FilePath ATSError
forall a b a'. Traversal (Either a b) (Either a' b) a a'
_Left FilePath -> ATSError
LexError

stripComments :: [Token] -> [Token]
stripComments :: [Token] -> [Token]
stripComments = (Token -> Bool) -> [Token] -> [Token]
forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
nc
    where nc :: Token -> Bool
nc CommentLex{}      = Bool
False
          nc CommentBegin{}    = Bool
False
          nc CommentEnd{}      = Bool
False
          nc CommentContents{} = Bool
False
          nc Token
_                 = Bool
True

-- | Parse with some fixity declarations already in scope.
parseWithCtx :: FixityState AlexPosn -> ([Token] -> [Token]) -> String -> Either ATSError (ATS AlexPosn)
parseWithCtx :: FixityState AlexPosn
-> ([Token] -> [Token])
-> FilePath
-> Either ATSError (ATS AlexPosn)
parseWithCtx FixityState AlexPosn
st [Token] -> [Token]
p = [Token] -> Either ATSError (ATS AlexPosn)
stateParse ([Token] -> Either ATSError (ATS AlexPosn))
-> (FilePath -> Either ATSError [Token])
-> FilePath
-> Either ATSError (ATS AlexPosn)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< FilePath -> Either ATSError [Token]
lex'
    where withSt :: StateT (FixityState AlexPosn) m a -> m (a, FixityState AlexPosn)
withSt = StateT (FixityState AlexPosn) m a
-> FixityState AlexPosn -> m (a, FixityState AlexPosn)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (StateT (FixityState AlexPosn) m a
 -> FixityState AlexPosn -> m (a, FixityState AlexPosn))
-> FixityState AlexPosn
-> StateT (FixityState AlexPosn) m a
-> m (a, FixityState AlexPosn)
forall a b c. (a -> b -> c) -> b -> a -> c
-$ FixityState AlexPosn
st
          lex' :: FilePath -> Either ATSError [Token]
lex' = Either FilePath [Token] -> Either ATSError [Token]
forall a. Either FilePath a -> Either ATSError a
lexErr (Either FilePath [Token] -> Either ATSError [Token])
-> (FilePath -> Either FilePath [Token])
-> FilePath
-> Either ATSError [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Token] -> [Token])
-> Either FilePath [Token] -> Either FilePath [Token]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Token] -> [Token]
p (Either FilePath [Token] -> Either FilePath [Token])
-> (FilePath -> Either FilePath [Token])
-> FilePath
-> Either FilePath [Token]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Either FilePath [Token]
lexATS
          stateParse :: [Token] -> Either ATSError (ATS AlexPosn)
stateParse = ((ATS AlexPosn, FixityState AlexPosn) -> ATS AlexPosn)
-> Either ATSError (ATS AlexPosn, FixityState AlexPosn)
-> Either ATSError (ATS AlexPosn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ATS AlexPosn, FixityState AlexPosn) -> ATS AlexPosn
forall a. Eq a => (ATS a, FixityState a) -> ATS a
rewriteATS' (Either ATSError (ATS AlexPosn, FixityState AlexPosn)
 -> Either ATSError (ATS AlexPosn))
-> ([Token]
    -> Either ATSError (ATS AlexPosn, FixityState AlexPosn))
-> [Token]
-> Either ATSError (ATS AlexPosn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (FixityState AlexPosn) (Either ATSError) (ATS AlexPosn)
-> Either ATSError (ATS AlexPosn, FixityState AlexPosn)
forall (m :: * -> *) a.
StateT (FixityState AlexPosn) m a -> m (a, FixityState AlexPosn)
withSt (StateT (FixityState AlexPosn) (Either ATSError) (ATS AlexPosn)
 -> Either ATSError (ATS AlexPosn, FixityState AlexPosn))
-> ([Token]
    -> StateT (FixityState AlexPosn) (Either ATSError) (ATS AlexPosn))
-> [Token]
-> Either ATSError (ATS AlexPosn, FixityState AlexPosn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Token]
-> StateT (FixityState AlexPosn) (Either ATSError) (ATS AlexPosn)
parseATS

-- | Extract a list of files that some code depends on.
getDependencies :: ATS a -> [FilePath]
getDependencies :: ATS a -> [FilePath]
getDependencies (ATS [Declaration a]
ds) = Declaration a -> [FilePath]
forall a. Declaration a -> [FilePath]
g (Declaration a -> [FilePath]) -> [Declaration a] -> [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Declaration a]
ds
    where g :: Declaration a -> [FilePath]
g (Load Bool
_ Bool
_ Maybe FilePath
_ FilePath
s)   = [FilePath
s]
          g (Include FilePath
s)      = [FilePath
s]
          g (Local a
_ ATS a
as ATS a
as') = ATS a -> [FilePath]
forall a. ATS a -> [FilePath]
getDependencies (ATS a -> [FilePath]) -> [ATS a] -> [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ATS a
as, ATS a
as']
          g Declaration a
_                = [FilePath]
forall a. Monoid a => a
mempty

-- | Extract a list of @#include#-ed filepaths, plus all external C blocks.
--
-- @since 1.7.7.0
getDependenciesC :: ATS a -> ([FilePath], [String])
getDependenciesC :: ATS a -> ([FilePath], [FilePath])
getDependenciesC (ATS [Declaration a]
ds) = [([FilePath], [FilePath])] -> ([FilePath], [FilePath])
forall a b. [([a], [b])] -> ([a], [b])
go (Declaration a -> ([FilePath], [FilePath])
forall a. Declaration a -> ([FilePath], [FilePath])
d (Declaration a -> ([FilePath], [FilePath]))
-> [Declaration a] -> [([FilePath], [FilePath])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Declaration a]
ds)
    where
        d :: Declaration a -> ([FilePath], [FilePath])
d (Load Bool
_ Bool
_ Maybe FilePath
_ FilePath
s)   = ([FilePath
s], [])
        d (Include FilePath
s)      = ([FilePath
s], [])
        d (Local a
_ ATS a
as ATS a
as') = ([FilePath], [FilePath])
-> ([FilePath], [FilePath]) -> ([FilePath], [FilePath])
forall a b. ([a], [b]) -> ([a], [b]) -> ([a], [b])
appendBoth (ATS a -> ([FilePath], [FilePath])
forall a. ATS a -> ([FilePath], [FilePath])
getDependenciesC ATS a
as) (ATS a -> ([FilePath], [FilePath])
forall a. ATS a -> ([FilePath], [FilePath])
getDependenciesC ATS a
as')
        d (CBlock FilePath
str)     = ([],[FilePath
str])
        d Declaration a
_                = ([],[])
        appendBoth :: ([a], [b]) -> ([a], [b]) -> ([a], [b])
        appendBoth :: ([a], [b]) -> ([a], [b]) -> ([a], [b])
appendBoth ([a]
x, [b]
y) ([a]
x', [b]
y') = ([a]
x [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
x', [b]
y [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
y')
        go :: [([a], [b])] -> ([a], [b])
        go :: [([a], [b])] -> ([a], [b])
go [([a], [b])]
xs = ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([a], [b]) -> [a]
forall a b. (a, b) -> a
fst (([a], [b]) -> [a]) -> [([a], [b])] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([a], [b])]
xs), [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([a], [b]) -> [b]
forall a b. (a, b) -> b
snd (([a], [b]) -> [b]) -> [([a], [b])] -> [[b]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([a], [b])]
xs))