Unary operators (#51)

* Unary ops & some initial error reworking.

* Add unary negate to prelude

* Prelude tidy

Author: gmorpheme

lib/prelude.eu

@@ -164,37 +164,45 @@ lookup-alts(syms, d, b): foldr(lookup-or-in(b), d, syms)
 ## Boolean
 ##
 
-` { doc: "`not(b) - toggle boolean.`"
+` { doc: "`not(b) - toggle boolean."
     export: :suppress }
 not: __NOT
 
-` { doc: "`l && r`` - true if and only if `l` and `r` are true."
+` { doc: "`!x` - not x, toggle boolean."
+    precedence: :bool-unary }
+(! b): b not
+
+` { doc: "`¬x` - not x, toggle boolean."
+    precedence: :bool-unary }
+(¬ b): b not
+
+` { doc: "`l && r` - true if and only if `l` and `r` are true."
     export: :suppress
     associates: :left
     precedence: :bool-prod }
 (l && r): __AND(l, r)
 
-` { doc: "`and(l, r)`` - true if and only if `l` and `r` are true."
+` { doc: "`and(l, r)` - true if and only if `l` and `r` are true."
     export: :suppress }
 and: __AND
 
-` { doc: "`l ∧ r`` - true if and only if `l` and `r`"
+` { doc: "`l ∧ r` - true if and only if `l` and `r`"
     export: :suppress
     associates: :left
     precedence: :bool-prod }
 (l ∧ r): l && r
 
-` { doc: "`or(l, r)`` - true if and only if `l` or `r` is true."
+` { doc: "`or(l, r)` - true if and only if `l` or `r` is true."
     export: :suppress }
 or: __OR
 
-` { doc: "`l || r`` - true if and only if `l` or `r`"
+` { doc: "`l || r` - true if and only if `l` or `r`"
     export: :suppress
     associates: :left
     precedence: :bool-sum }
 (l || r): __OR(l, r)
 
-` { doc: "`l ∨ r`` - true if and only if `l` or `r`"
+` { doc: "`l ∨ r` - true if and only if `l` or `r`"
     export: :suppress
     associates: :left
     precedence: :bool-sum }
@@ -444,13 +452,10 @@ nth(n, l): l drop(n dec) head
 ` { doc: "`l !! n` - return `n`th item of list if it exists, otherwise error."}
 (l !! n): l nth(n)
 
-# TODO: Can't use this until lists are exposed to eu as cons is not
-# currently lazy enough
 ` { doc: "`repeat(i)` - return infinite list of instances of item `i`."
     export: :suppress }
 repeat(i): __CONS(i, repeat(i))
 
-# TODO: sections
 ` { doc: "`foldl(op, i, l)` - left fold operator `op` over list `l` starting from value `i` "
     # example: foldl(+, i, [1,2,3]) //=> (((i + 1) + 2) + 3)
     export: :suppress }
@@ -470,9 +475,7 @@ _impl: {
     export: :suppress }
 count(l): foldl(_impl.const-apply2(inc), 0, l)
 
-# TODO: lambdas
 ` { doc: "`map(f, l)` - map function `f` over list `l`"
-    # example: map(|x|(x+2),[1,2,3]) //=> [3,4,5]
     export: :suppress }
 map(f, l): if(l nil?, l, cons(l head f, l tail map(f)))
 

src/Eucalypt/Core/Desugar.hs

@@ -157,10 +157,15 @@ translateDeclarationForm a _k Located {locatee = form} =
     (PropertyDecl _ expr) -> varifyTranslate expr
     (FunctionDecl _ as expr) -> lam as <$> varifyTranslate expr
     (OperatorDecl _ l r expr) -> newOp l r <$> varifyTranslate expr
+    (LeftOperatorDecl _ x expr) -> newUnOp UnaryPrefix x <$> varifyTranslate expr
+    (RightOperatorDecl _ x expr) -> newUnOp UnaryPostfix x <$> varifyTranslate expr
   where
     newOp l r expr =
       let (fixity, precedence) = determineFixity a
        in CoreOperator fixity precedence $ lam [l, r] expr
+    newUnOp fixity x expr =
+      let precedence = determinePrecedence a
+       in CoreOperator fixity precedence $ lam [x] expr
     varifyTranslate = translate >=> return . varify
 
 
@@ -206,6 +211,8 @@ translateBlock blk = do
               (PropertyDecl k _) -> k
               (FunctionDecl k _ _) -> k
               (OperatorDecl k _ _ _) -> k
+              (LeftOperatorDecl k _ _) -> k
+              (RightOperatorDecl k _ _) -> k
        in atomicName name
     bindings =
       map

src/Eucalypt/Core/Metadata.hs

@@ -82,6 +82,7 @@ precedenceClasses :: [(String, Precedence)]
 precedenceClasses =
   [ ("lookup", 100)
   , ("call", 90)
+  , ("bool-unary", 88)
   , ("exp", 85)
   , ("prod", 80)
   , ("sum", 75)
@@ -113,6 +114,15 @@ determineFixity (Just meta) = (fixity, fromMaybe 50 prec)
         _ -> 50
 determineFixity Nothing = (InfixLeft, 50)
 
+-- | Determine precedence when fixity is already known (i.e. unary).
+determinePrecedence :: Maybe CoreExpr -> Precedence
+determinePrecedence (Just meta) =
+  fromMaybe 50 $
+  readUnevaluatedMetadata "precedence" meta $ \case
+    (CorePrim (CoreInt n)) -> fromInteger n
+    (CorePrim (CoreSymbol cls)) -> (fromMaybe 50 (lookup cls precedenceClasses))
+    _ -> 50
+determinePrecedence _ = 50
 
 -- | Check (unevaluated) metadata for target annotations and their
 -- documentation

src/Eucalypt/Driver/Evaluator.hs

@@ -46,7 +46,7 @@ import Eucalypt.Driver.Lib (getResource)
 import Eucalypt.Driver.Options (Command(..), EucalyptOptions(..))
 import qualified Eucalypt.Driver.Stg as STG
 import Eucalypt.Reporting.Error (EucalyptError(..))
-import Eucalypt.Reporting.Report (reportErrors)
+import Eucalypt.Reporting.Report (reportErrors, tryOrReport)
 import Eucalypt.Source.Error (DataParseException(..))
 import Eucalypt.Source.TomlSource
 import Eucalypt.Source.YamlSource
@@ -183,8 +183,9 @@ parseUnits :: (Traversable t, Foldable t) => t Input -> IO [TranslationUnit]
 parseUnits inputs = do
   asts <- traverse parseInputToCore inputs
   case partitionEithers (toList asts) of
-    (errs@(_:_), _) -> reportErrors errs >> exitFailure
-    ([], []) -> reportErrors [NoSource] >> exitFailure
+    -- TODO: propagate all errors
+    (e:_, _) -> throwM e
+    ([], []) -> throwM NoSource
     ([], units) -> return units
 
 
@@ -274,7 +275,7 @@ parseInputsAndImports inputs = do
 
 -- | Implement the Evaluate command, read files and render
 evaluate :: EucalyptOptions -> IO ExitCode
-evaluate opts = do
+evaluate opts = tryOrReport $ do
   when (cmd == Parse) (parseAndDumpASTs opts >> exitSuccess)
 
   -- Stage 1: parse inputs and translate to core units

src/Eucalypt/Reporting/Classes.hs

@@ -0,0 +1,18 @@
+{-|
+Module      : Eucalypt.Reporting.Classes
+Description : Type classes to implement for error reporting
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
+module Eucalypt.Reporting.Classes where
+
+import Eucalypt.Reporting.Location as L
+import Text.PrettyPrint as P
+
+class Reportable a where
+  -- | Location in SourceCode
+  code :: a -> Maybe L.SourceSpan
+  -- | Formatted error report
+  report :: a -> P.Doc

src/Eucalypt/Reporting/Error.hs

@@ -1,12 +1,22 @@
+{-|
+Module      : Eucalypt.Syntax.Error
+Description : Aggregated error type for all types of errors
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
 module Eucalypt.Reporting.Error
   where
 
+import Control.Exception (SomeException)
+import Control.Exception.Safe
 import qualified Eucalypt.Core.Error as Core
+import qualified Eucalypt.Driver.Error as Driver
+import Eucalypt.Reporting.Classes
 import qualified Eucalypt.Source.Error as Source
 import qualified Eucalypt.Syntax.Error as Syntax
-import qualified Eucalypt.Driver.Error as Driver
-import Control.Exception (SomeException)
-
+import qualified Text.PrettyPrint as P
 
 -- | All the types of error that Eucalypt can experience and report
 data EucalyptError
@@ -15,4 +25,13 @@ data EucalyptError
   | Syntax Syntax.SyntaxError
   | System SomeException
   | Command Driver.CommandError
-  deriving (Show)
+  deriving (Show, Typeable)
+
+instance Exception EucalyptError
+
+instance Reportable EucalyptError where
+  code (Syntax e) = code e
+  code _ = Nothing
+
+  report (Syntax e) = report e
+  report e = P.text $ show e

src/Eucalypt/Reporting/Report.hs

@@ -1,7 +1,40 @@
+{-|
+Module      : Eucalypt.Reporting.Report
+Description : Facilities for reporting errors
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
 module Eucalypt.Reporting.Report where
 
-import System.IO (hPrint, stderr)
+import Eucalypt.Reporting.Error
+import Eucalypt.Reporting.Classes
+import System.Exit
+import System.IO
+import qualified Text.PrettyPrint as P
+import Control.Exception.Safe
 
 -- | Report any errors to stderr
 reportErrors :: Show a => [a] -> IO ()
 reportErrors = mapM_ (hPrint stderr)
+
+
+
+-- | Report an error to the console
+reportToConsole :: Reportable a => a -> IO ()
+reportToConsole e = hPutStr stderr $ P.render $ report e
+
+
+
+-- | Attempt an IO action, but report and abort in the case of a
+-- reportable error.
+tryOrReport :: IO a -> IO a
+tryOrReport action = do
+  result <- tryJust eucalyptError action
+  case result of
+    Left e -> reportToConsole e >> exitFailure
+    Right v -> return v
+  where
+    eucalyptError :: EucalyptError -> Maybe EucalyptError
+    eucalyptError = Just

src/Eucalypt/Syntax/Ast.hs

@@ -157,25 +157,33 @@ type DeclarationForm = Located DeclarationForm_
 -- This may be any of
 -- * a property declaration
 -- * a function declaration
--- * an operator declaration
+-- * an operator declaration (binary, left or right unary)
 data DeclarationForm_
 
-  = PropertyDecl AtomicName Expression |
+  = PropertyDecl AtomicName Expression
     -- ^ A simple property declaration: @key: value-expression@
 
-    FunctionDecl AtomicName [ParameterName] Expression |
+  | FunctionDecl AtomicName [ParameterName] Expression
     -- ^ A function declaration @f(x, y, z): value-expression@
 
-    OperatorDecl AtomicName ParameterName ParameterName Expression
+  | OperatorDecl AtomicName ParameterName ParameterName Expression
     -- ^ A binary operator declaration @(x ** y): value-expression@
 
+  | LeftOperatorDecl AtomicName ParameterName Expression
+    -- ^ A left unary operator declaration @(! x): value-expression@
+
+  | RightOperatorDecl AtomicName ParameterName Expression
+    -- ^ A right unary operator declaration @(x !): value-expression@
+
   deriving (Eq, Show, Generic, ToJSON)
 
 
 instance HasLocation DeclarationForm_ where
   stripLocation (PropertyDecl n e) = PropertyDecl n (stripLocation e)
   stripLocation (FunctionDecl f ps e) = FunctionDecl f ps (stripLocation e)
   stripLocation (OperatorDecl n l r e) = OperatorDecl n l r (stripLocation e)
+  stripLocation (LeftOperatorDecl n o e) = LeftOperatorDecl n o (stripLocation e)
+  stripLocation (RightOperatorDecl n o e) = RightOperatorDecl n o (stripLocation e)
 
 type BlockElement = Located BlockElement_
 
@@ -236,6 +244,14 @@ func f params e = at nowhere $ FunctionDecl (NormalName f) params e
 oper :: String -> String -> String -> Expression -> DeclarationForm
 oper o l r e = at nowhere $ OperatorDecl (OperatorName o) l r e
 
+-- | Create an operator declaration
+loper :: String -> String -> Expression -> DeclarationForm
+loper o x e = at nowhere $ LeftOperatorDecl (OperatorName o) x e
+
+-- | Create an operator declaration
+roper :: String -> String -> Expression -> DeclarationForm
+roper o x e = at nowhere $ RightOperatorDecl (OperatorName o) x e
+
 -- | Create an annotated block element
 ann :: Expression -> DeclarationForm -> BlockElement
 ann a decl = at nowhere $ Declaration Annotated { annotation = Just a, content = decl }

src/Eucalypt/Syntax/Error.hs

@@ -1,11 +1,34 @@
+{-|
+Module      : Eucalypt.Syntax.Error
+Description : Syntax errors from source or input specs
+Copyright   : (c) Greg Hawkins, 2018
+License     :
+Maintainer  : greg@curvelogic.co.uk
+Stability   : experimental
+-}
 module Eucalypt.Syntax.Error where
 
 import Control.Exception.Safe
+import Data.List.NonEmpty as NE
 import Data.Void
+import Eucalypt.Reporting.Classes
+import Eucalypt.Reporting.Location
 import qualified Text.Megaparsec as M
+import qualified Text.PrettyPrint as P
 
 newtype SyntaxError
   = MegaparsecError (M.ParseError (M.Token String) Void)
   deriving (Show, Eq, Typeable)
 
 instance Exception SyntaxError
+
+toSpan :: NonEmpty M.SourcePos -> SourceSpan
+toSpan positions = (h, h)
+  where
+    h = SourcePosition $ NE.head positions
+
+-- | Make SyntaxError 'Reportable'
+instance Reportable SyntaxError where
+  code (MegaparsecError pe) = Just . toSpan . M.errorPos $ pe
+  report (MegaparsecError pe) = P.text "SYNTAX ERROR" P.$$ P.text msg
+    where msg = M.parseErrorPretty pe