diff --git a/language-ats.cabal b/language-ats.cabal --- a/language-ats.cabal +++ b/language-ats.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: language-ats -version: 1.1.0.0 +version: 1.2.0.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale @@ -48,7 +48,6 @@ ansi-wl-pprint >=0.6.8, recursion-schemes >=5.0.1, composition-prelude -any, - ansi-terminal -any, containers -any, mtl -any, transformers -any diff --git a/src/Language/ATS.hs b/src/Language/ATS.hs --- a/src/Language/ATS.hs +++ b/src/Language/ATS.hs @@ -9,9 +9,11 @@ , printATSCustom , printATSFast , printErr + , warnErr , defaultFixityState -- * Library functions , getDependencies + , getDeps -- * Syntax Tree , ATS (..) , Declaration (..) @@ -46,7 +48,7 @@ , AlexPosn (..) , Keyword (..) -- * Error types - , ATSError + , ATSError (..) -- * Lenses , preF , expression @@ -75,6 +77,10 @@ printErr :: MonadIO m => ATSError -> m () printErr = liftIO . hPutDoc stderr . (<> "\n") . pretty +-- | Same as 'printErr', but print a yellow warning message instead. +warnErr :: MonadIO m => ATSError -> m () +warnErr = liftIO . hPutDoc stderr . (dullyellow "Warning" <+>) . preErr + -- | Parse a string containing ATS source. parse :: String -> Either ATSError (ATS AlexPosn) parse = parseWithCtx defaultFixityState @@ -85,6 +91,14 @@ where withSt = flip runStateT st lexErr = over _Left LexError . lexATS stateParse = fmap rewriteATS' . withSt . parseATS + +-- FIXME should we use a pattern synonym? +getDeps :: [Token] -> [FilePath] +getDeps (Keyword _ KwStaload{}:StringTok _ s:xs) = (init . drop 1) s : getDeps xs +getDeps (Keyword _ KwDynload{}:StringTok _ s:xs) = (init . drop 1) s : getDeps xs +getDeps (Keyword _ KwInclude{}:StringTok _ s:xs) = (init . drop 1) s : getDeps xs +getDeps (_:xs) = getDeps xs +getDeps [] = mempty -- | Extract a list of files that some code depends on. getDependencies :: ATS a -> [FilePath] diff --git a/src/Language/ATS/Lexer.x b/src/Language/ATS/Lexer.x --- a/src/Language/ATS/Lexer.x +++ b/src/Language/ATS/Lexer.x @@ -1,6 +1,6 @@ { - {-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-incomplete-uni-patterns -fno-warn-unused-imports -fno-warn-orphans #-} + {-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-incomplete-uni-patterns -fno-warn-unused-imports -fno-warn-orphans -fno-warn-name-shadowing #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE StandaloneDeriving #-} diff --git a/src/Language/ATS/Parser.y b/src/Language/ATS/Parser.y --- a/src/Language/ATS/Parser.y +++ b/src/Language/ATS/Parser.y @@ -7,6 +7,7 @@ -- | This module contains the parser. module Language.ATS.Parser ( parseATS , ATSError (..) + , preErr ) where import Language.ATS.Types @@ -694,7 +695,8 @@ | fun fn {% left $ Expected $2 "Function name" "fn" } | fn fun {% left $ Expected $2 "Function name" "fun" } | extern FunDecl identifier openParen {% left $ Expected (token_posn $3) "Static integer expression" (to_string $3) } - | extern identifier {% left $ OneOf (token_posn $2) ["fun", "fn", "prfun", "prfun", "praxi", "castfn", "fnx", "val"] (to_string $2) } + | extern identifier {% left $ OneOf (token_posn $2) ["fun", "fn", "prfun", "prfun", "praxi", "castfn", "fnx", "val", "typedef", "vtypedef"] (to_string $2) } + | extern extern {% left $ OneOf $2 ["fun", "fn", "prfun", "prfun", "praxi", "castfn", "fnx", "val", "typedef", "vtypedef"] "extern" } IdentifierOr : identifier { to_string $1 } | identifierSpace { to_string $1 } @@ -904,7 +906,7 @@ pretty (AlexPn _ line col) = pretty line <> ":" <> pretty col unmatched :: AlexPosn -> String -> Doc -unmatched l chr = red "Error:" <+> "unmatched" <+> squotes (text chr) <+> "at" <+> pretty l <> linebreak +unmatched l chr = "unmatched" <+> squotes (text chr) <+> "at" <+> pretty l <> linebreak bear :: Bool -> [Doc] -> Doc bear _ [] = mempty @@ -913,13 +915,15 @@ bear _ (x:xs) = x <> "," <+> bear True xs instance Pretty ATSError where - pretty (OneOf p ss s) = red "Error:" <+> pretty p <> linebreak <> (indent 2 $ "Unexpected" <+> squotes (text s) <> ", expected one of" <+> bear False (fmap (squotes . text) ss)) <> linebreak - pretty (Expected p s1 s2) = red "Error:" <+> pretty p <> linebreak <> (indent 2 $ "Unexpected" <+> squotes (text s2) <> ", expected:" <+> squotes (text s1)) <> linebreak - pretty (Unknown (Special l ")")) = unmatched l ")" - pretty (Unknown (Special l "}")) = unmatched l "}" - pretty (Unknown (Special l ">")) = unmatched l ">" - pretty (Unknown t) = red "Error:" <+> "unexpected token" <+> squotes (pretty t) <+> "at" <+> pretty (token_posn t) <> linebreak - pretty (LexError s) = red "Lexical error:" <+> text s + pretty = (red "Error:" <+>) . preErr + +preErr (OneOf p ss s) = pretty p <> linebreak <> (indent 2 $ "Unexpected" <+> squotes (text s) <> ", expected one of" <+> bear False (fmap (squotes . text) ss)) <> linebreak +preErr (Expected p s1 s2) = pretty p <> linebreak <> (indent 2 $ "Unexpected" <+> squotes (text s2) <> ", expected:" <+> squotes (text s1)) <> linebreak +preErr (Unknown (Special l ")")) = unmatched l ")" +preErr (Unknown (Special l "}")) = unmatched l "}" +preErr (Unknown (Special l ">")) = unmatched l ">" +preErr (Unknown t) = "unexpected token" <+> squotes (pretty t) <+> "at" <+> pretty (token_posn t) <> linebreak +preErr (LexError s) = red "Lexical error:" <+> text s left :: ATSError -> ParseSt b left = lift . Left diff --git a/src/Language/ATS/PrettyPrint.hs b/src/Language/ATS/PrettyPrint.hs --- a/src/Language/ATS/PrettyPrint.hs +++ b/src/Language/ATS/PrettyPrint.hs @@ -14,34 +14,14 @@ , printATSFast ) where -import Control.Composition hiding ((&)) -import Control.DeepSeq (NFData) -import Data.Functor.Foldable (cata) -import GHC.Generics (Generic) +import Control.Composition hiding ((&)) +import Data.Functor.Foldable (cata) import Language.ATS.Types import Lens.Micro -import Prelude hiding ((<$>)) -import System.Console.ANSI.Types -import Text.PrettyPrint.ANSI.Leijen hiding (bool) -import Text.PrettyPrint.ANSI.Leijen.Internal hiding (bool) +import Prelude hiding ((<$>)) +import Text.PrettyPrint.ANSI.Leijen hiding (bool) infixr 5 $$ - -deriving instance Generic Underlining -deriving instance NFData Underlining -deriving instance Generic ConsoleIntensity -deriving instance NFData ConsoleIntensity -deriving instance Generic Color -deriving instance NFData Color -deriving instance Generic ColorIntensity -deriving instance NFData ColorIntensity -deriving instance Generic ConsoleLayer -deriving instance NFData ConsoleLayer -deriving instance Generic Doc -deriving instance NFData Doc - -instance Eq Doc where - (==) = on (==) show pattern NoA :: [Arg a] pattern NoA = [NoArgs]