github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 09:15:01 +03:00
Code Issues Projects Releases Wiki Activity

DerivingVia over Syntax.Statement.

Browse Source
This commit is contained in:
Patrick Thomson 2019-01-07 15:33:50 -05:00
parent d4c9702d7e
commit e0d5e7f54b
1 changed files with 30 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

147
src/Data/Syntax/Statement.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DeriveAnyClass, ScopedTypeVariables, UndecidableInstances, ViewPatterns, DuplicateRecordFields #-}
{-# LANGUAGE DeriveAnyClass, DerivingVia, ScopedTypeVariables, UndecidableInstances, ViewPatterns, DuplicateRecordFields #-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-}
module Data.Syntax.Statement where
@ -26,10 +26,8 @@ import qualified Data.Reprinting.Scope as Scope
-- TODO: Separate top-level statement nodes into non-lexical Statement and lexical StatementBlock nodes
newtype Statements a = Statements { statements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1)
deriving (Eq1, Show1, Ord1) via Generically Statements
instance Eq1 Statements where liftEq = genericLiftEq
instance Ord1 Statements where liftCompare = genericLiftCompare
instance Show1 Statements where liftShowsPrec = genericLiftShowsPrec
instance ToJSON1 Statements
instance Evaluatable Statements where
@ -41,10 +39,8 @@ instance Tokenize Statements where
newtype StatementBlock a = StatementBlock { statements :: [a] }
deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1, NFData1)
deriving (Eq1, Show1, Ord1) via Generically StatementBlock
instance Eq1 StatementBlock where liftEq = genericLiftEq
instance Ord1 StatementBlock where liftCompare = genericLiftCompare
instance Show1 StatementBlock where liftShowsPrec = genericLiftShowsPrec
instance ToJSON1 StatementBlock
instance Evaluatable StatementBlock where
@ -57,10 +53,7 @@ instance Tokenize StatementBlock where
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 If where liftEq = genericLiftEq
instance Ord1 If where liftCompare = genericLiftCompare
instance Show1 If where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically If
instance Evaluatable If where
eval eval _ (If cond if' else') = do
@ -78,10 +71,7 @@ instance Tokenize If where
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
data Else a = Else { elseCondition :: !a, elseBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Else where liftEq = genericLiftEq
instance Ord1 Else where liftCompare = genericLiftCompare
instance Show1 Else where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Else
-- TODO: Implement Eval instance for Else
instance Evaluatable Else
@ -94,22 +84,15 @@ instance Tokenize Else where
-- | Goto statement (e.g. `goto a` in Go).
newtype Goto a = Goto { gotoLocation :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Goto where liftEq = genericLiftEq
instance Ord1 Goto where liftCompare = genericLiftCompare
instance Show1 Goto where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Goto
-- TODO: Implement Eval instance for Goto
instance Evaluatable Goto
-- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Match where liftEq = genericLiftEq
instance Ord1 Match where liftCompare = genericLiftCompare
instance Show1 Match where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Match
-- TODO: Implement Eval instance for Match
instance Evaluatable Match
@ -124,10 +107,7 @@ instance Tokenize Match where
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
data Pattern a = Pattern { value :: !a, patternBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Pattern where liftEq = genericLiftEq
instance Ord1 Pattern where liftCompare = genericLiftCompare
instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Pattern
-- TODO: Implement Eval instance for Pattern
instance Evaluatable Pattern
@ -138,10 +118,7 @@ instance Tokenize Pattern where
-- | A let statement or local binding, like 'a as b' or 'let a = b'.
data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Let where liftEq = genericLiftEq
instance Ord1 Let where liftCompare = genericLiftCompare
instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Let
instance Evaluatable Let where
eval eval _ Let{..} = do
@ -164,14 +141,11 @@ instance Evaluatable Let where
-- | Assignment to a variable or other lvalue.
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
deriving (Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
deriving (Eq1, Show1, Ord1) via Generically Assignment
instance Declarations1 Assignment where
liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget
instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare
instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Assignment where
eval eval ref Assignment{..} = do
lhs <- ref assignmentTarget
@ -198,10 +172,7 @@ instance Tokenize Assignment where
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
newtype PostIncrement a = PostIncrement { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 PostIncrement where liftEq = genericLiftEq
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
instance Show1 PostIncrement where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically PostIncrement
-- TODO: Implement Eval instance for PostIncrement
instance Evaluatable PostIncrement
@ -210,10 +181,7 @@ instance Evaluatable PostIncrement
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
newtype PostDecrement a = PostDecrement { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 PostDecrement where liftEq = genericLiftEq
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
instance Show1 PostDecrement where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically PostDecrement
-- TODO: Implement Eval instance for PostDecrement
instance Evaluatable PostDecrement
@ -221,10 +189,7 @@ instance Evaluatable PostDecrement
-- | Pre increment operator (e.g. ++1 in C or Java).
newtype PreIncrement a = PreIncrement { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 PreIncrement where liftEq = genericLiftEq
instance Ord1 PreIncrement where liftCompare = genericLiftCompare
instance Show1 PreIncrement where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically PreIncrement
-- TODO: Implement Eval instance for PreIncrement
instance Evaluatable PreIncrement
@ -233,10 +198,7 @@ instance Evaluatable PreIncrement
-- | Pre decrement operator (e.g. --1 in C or Java).
newtype PreDecrement a = PreDecrement { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 PreDecrement where liftEq = genericLiftEq
instance Ord1 PreDecrement where liftCompare = genericLiftCompare
instance Show1 PreDecrement where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically PreDecrement
-- TODO: Implement Eval instance for PreDecrement
instance Evaluatable PreDecrement
@ -246,10 +208,7 @@ instance Evaluatable PreDecrement
newtype Return a = Return { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Return where liftEq = genericLiftEq
instance Ord1 Return where liftCompare = genericLiftCompare
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Return
instance Evaluatable Return where
eval eval _ (Return x) = eval x >>= earlyReturn
@ -259,10 +218,7 @@ instance Tokenize Return where
newtype Yield a = Yield { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Yield where liftEq = genericLiftEq
instance Ord1 Yield where liftCompare = genericLiftCompare
instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Yield
-- TODO: Implement Eval instance for Yield
instance Evaluatable Yield
@ -273,10 +229,7 @@ instance Tokenize Yield where
newtype Break a = Break { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Break where liftEq = genericLiftEq
instance Ord1 Break where liftCompare = genericLiftCompare
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Break
instance Evaluatable Break where
eval eval _ (Break x) = eval x >>= throwBreak
@ -286,10 +239,7 @@ instance Tokenize Break where
newtype Continue a = Continue { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Continue where liftEq = genericLiftEq
instance Ord1 Continue where liftCompare = genericLiftCompare
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Continue
instance Evaluatable Continue where
eval eval _ (Continue x) = eval x >>= throwContinue
@ -299,10 +249,7 @@ instance Tokenize Continue where
newtype Retry a = Retry { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Retry where liftEq = genericLiftEq
instance Ord1 Retry where liftCompare = genericLiftCompare
instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Retry
-- TODO: Implement Eval instance for Retry
instance Evaluatable Retry
@ -312,10 +259,7 @@ instance Tokenize Retry where
newtype NoOp a = NoOp { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 NoOp where liftEq = genericLiftEq
instance Ord1 NoOp where liftCompare = genericLiftCompare
instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically NoOp
instance Evaluatable NoOp where
eval _ _ _ = pure unit
@ -324,21 +268,14 @@ instance Evaluatable NoOp where
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 For where liftEq = genericLiftEq
instance Ord1 For where liftCompare = genericLiftCompare
instance Show1 For where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically For
instance Evaluatable For where
eval eval _ (fmap eval -> For before cond step body) = forLoop before cond step body
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 ForEach where liftEq = genericLiftEq
instance Ord1 ForEach where liftCompare = genericLiftCompare
instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically ForEach
-- TODO: Implement Eval instance for ForEach
instance Evaluatable ForEach
@ -353,10 +290,7 @@ instance Tokenize ForEach where
data While a = While { whileCondition :: !a, whileBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 While where liftEq = genericLiftEq
instance Ord1 While where liftCompare = genericLiftCompare
instance Show1 While where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically While
instance Evaluatable While where
eval eval _ While{..} = while (eval whileCondition) (eval whileBody)
@ -369,10 +303,7 @@ instance Tokenize While where
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 DoWhile where liftEq = genericLiftEq
instance Ord1 DoWhile where liftCompare = genericLiftCompare
instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically DoWhile
instance Evaluatable DoWhile where
eval eval _ DoWhile{..} = doWhile (eval doWhileBody) (eval doWhileCondition)
@ -381,10 +312,7 @@ instance Evaluatable DoWhile where
newtype Throw a = Throw { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Throw where liftEq = genericLiftEq
instance Ord1 Throw where liftCompare = genericLiftCompare
instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Throw
-- TODO: Implement Eval instance for Throw
instance Evaluatable Throw
@ -392,10 +320,7 @@ instance Evaluatable Throw
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Try where liftEq = genericLiftEq
instance Ord1 Try where liftCompare = genericLiftCompare
instance Show1 Try where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Try
-- TODO: Implement Eval instance for Try
instance Evaluatable Try
@ -409,10 +334,7 @@ instance Tokenize Try where
data Catch a = Catch { catchException :: !a, catchBody :: !a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Catch where liftEq = genericLiftEq
instance Ord1 Catch where liftCompare = genericLiftCompare
instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Catch
-- TODO: Implement Eval instance for Catch
instance Evaluatable Catch
@ -422,10 +344,7 @@ instance Tokenize Catch where
newtype Finally a = Finally { value :: a }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 Finally where liftEq = genericLiftEq
instance Ord1 Finally where liftCompare = genericLiftCompare
instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically Finally
-- TODO: Implement Eval instance for Finally
instance Evaluatable Finally
@ -438,10 +357,7 @@ instance Tokenize Finally where
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
newtype ScopeEntry a = ScopeEntry { terms :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 ScopeEntry where liftEq = genericLiftEq
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically ScopeEntry
-- TODO: Implement Eval instance for ScopeEntry
instance Evaluatable ScopeEntry
@ -453,10 +369,7 @@ instance Tokenize ScopeEntry where
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
newtype ScopeExit a = ScopeExit { terms :: [a] }
deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1, NFData1)
instance Eq1 ScopeExit where liftEq = genericLiftEq
instance Ord1 ScopeExit where liftCompare = genericLiftCompare
instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec
deriving (Eq1, Show1, Ord1) via Generically ScopeExit
-- TODO: Implement Eval instance for ScopeExit
instance Evaluatable ScopeExit