mirror of
https://github.com/github/semantic.git
synced 2024-11-29 21:52:59 +03:00
Drop Data.Syntax.
This commit is contained in:
Patrick Thomson
parent
af28098a73
commit
5791c8c793
@ -1,272 +0,0 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Data.Syntax (module Data.Syntax) where
|
||||
|
||||
|
||||
import qualified Assigning.Assignment as Assignment
|
||||
import Control.Abstract.Heap (deref, lookupSlot)
|
||||
import Control.Abstract.ScopeGraph (Declaration (..), Reference (..), reference)
|
||||
import Data.Abstract.Evaluatable hiding (Empty, Error)
|
||||
import qualified Data.Abstract.ScopeGraph as ScopeGraph
|
||||
import Data.Aeson as Aeson (ToJSON (..), object)
|
||||
import Data.Aeson ((.=))
|
||||
import Data.Bifunctor
|
||||
import qualified Data.Error as Error
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Functor.Foldable (cata)
|
||||
import Data.Hashable
|
||||
import Data.Hashable.Lifted
|
||||
import Data.Ix
|
||||
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup (sconcat)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Sum
|
||||
import Data.Term
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import GHC.Stack
|
||||
import GHC.TypeLits
|
||||
import GHC.Types (Constraint)
|
||||
import Source.Loc
|
||||
import Source.Range as Range
|
||||
import Source.Span as Span
|
||||
|
||||
-- Combinators
|
||||
|
||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
|
||||
makeTerm :: (Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => ann -> syntax (term ann) -> term ann
|
||||
makeTerm ann = makeTerm' ann . inject
|
||||
|
||||
-- | Lift a union and an annotation into a term, ensuring the annotation encompasses all children.
|
||||
makeTerm' :: (Semigroup ann, Foldable (Syntax term), IsTerm term) => ann -> Syntax term (term ann) -> term ann
|
||||
makeTerm' ann syntax = termIn (sconcat (ann :| (termAnnotation <$> toList syntax))) syntax
|
||||
|
||||
-- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children. Removes extra structure if term is a list of a single item.
|
||||
makeTerm'' :: (Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, Foldable syntax, IsTerm term) => ann -> syntax (term ann) -> term ann
|
||||
makeTerm'' ann children = case toList children of
|
||||
[x] -> x
|
||||
_ -> makeTerm' ann (inject children)
|
||||
|
||||
-- | Lift non-empty syntax into a term, injecting the syntax into a union & appending all subterms’.annotations to make the new term’s annotation.
|
||||
makeTerm1 :: (HasCallStack, Element syntax syntaxes, Sum syntaxes ~ Syntax term, Semigroup ann, Apply Foldable syntaxes, IsTerm term) => syntax (term ann) -> term ann
|
||||
makeTerm1 = makeTerm1' . inject
|
||||
|
||||
-- | Lift a non-empty union into a term, appending all subterms’ annotations to make the new term’s annotation.
|
||||
makeTerm1' :: (HasCallStack, Semigroup ann, Foldable (Syntax term), IsTerm term) => Syntax term (term ann) -> term ann
|
||||
makeTerm1' syntax = case toList syntax of
|
||||
a : _ -> makeTerm' (termAnnotation a) syntax
|
||||
_ -> error "makeTerm1': empty structure"
|
||||
|
||||
-- | Construct an empty term at the current position.
|
||||
emptyTerm :: (Empty :< syntaxes, Sum syntaxes ~ Syntax term, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment grammar (term Loc)
|
||||
emptyTerm = makeTerm . startLocation <$> Assignment.location <*> pure Empty
|
||||
where startLocation Loc{..} = Loc (Range.point (Range.start byteRange)) (Span.point (Span.start span))
|
||||
|
||||
-- | Catch assignment errors into an error term.
|
||||
handleError :: (HasCallStack, Error :< syntaxes, Sum syntaxes ~ Syntax term, Enum grammar, Ix grammar, Show grammar, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment grammar (term Loc) -> Assignment.Assignment grammar (term Loc)
|
||||
handleError = flip Assignment.catchError (\ err -> makeTerm <$> Assignment.location <*> pure (errorSyntax (either id show <$> err) []) <* Assignment.source)
|
||||
|
||||
-- | Catch parse errors into an error term.
|
||||
parseError :: (Error :< syntaxes, Sum syntaxes ~ Syntax term, Bounded grammar, Enum grammar, Apply Foldable syntaxes, IsTerm term) => Assignment.Assignment grammar (term Loc)
|
||||
parseError = makeTerm <$> Assignment.token maxBound <*> pure (Error (ErrorStack $ errorSite <$> getCallStack (freezeCallStack callStack)) [] (Just "ParseError") [])
|
||||
|
||||
-- | Match context terms before a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
|
||||
contextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term)
|
||||
=> m (term ann)
|
||||
-> m (term ann)
|
||||
-> m (term ann)
|
||||
contextualize context rule = make <$> Assignment.manyThrough context rule
|
||||
where make (cs, node) = case nonEmpty cs of
|
||||
Just cs -> makeTerm1 (Context cs node)
|
||||
_ -> node
|
||||
|
||||
-- | Match context terms after a subject term and before a delimiter, returning the delimiter paired with a Context term if any context terms matched, or the subject term otherwise.
|
||||
postContextualizeThrough :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term)
|
||||
=> m (term ann)
|
||||
-> m (term ann)
|
||||
-> m delimiter
|
||||
-> m (term ann, delimiter)
|
||||
postContextualizeThrough context rule end = make <$> rule <*> Assignment.manyThrough context end
|
||||
where make node (cs, end) = case nonEmpty cs of
|
||||
Just cs -> (makeTerm1 (Context cs node), end)
|
||||
_ -> (node, end)
|
||||
|
||||
-- | Match context terms after a subject term, wrapping both up in a Context term if any context terms matched, or otherwise returning the subject term.
|
||||
postContextualize :: (HasCallStack, Context :< syntaxes, Sum syntaxes ~ Syntax term, Alternative m, Semigroup ann, Apply Foldable syntaxes, IsTerm term)
|
||||
=> m (term ann)
|
||||
-> m (term ann)
|
||||
-> m (term ann)
|
||||
postContextualize context rule = make <$> rule <*> many context
|
||||
where make node cs = case nonEmpty cs of
|
||||
Just cs -> makeTerm1 (Context cs node)
|
||||
_ -> node
|
||||
|
||||
-- | Match infix terms separated by any of a list of operators, with optional context terms following each operand.
|
||||
infixContext :: (Context :< syntaxes, Sum syntaxes ~ Syntax term, Assignment.Parsing m, Semigroup ann, HasCallStack, Apply Foldable syntaxes, IsTerm term)
|
||||
=> m (term ann)
|
||||
-> m (term ann)
|
||||
-> m (term ann)
|
||||
-> [m (term ann -> term ann -> Sum syntaxes (term ann))]
|
||||
-> m (Sum syntaxes (term ann))
|
||||
infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
|
||||
|
||||
class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where
|
||||
generate :: Monoid b => (forall f proxy. (Element f all, c f) => proxy f -> Integer -> b) -> b
|
||||
|
||||
instance Generate c all '[] where
|
||||
generate _ = mempty
|
||||
|
||||
instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) where
|
||||
generate each = each (Proxy @f) (natVal (Proxy @(ElemIndex f all))) `mappend` generate @c @all @fs each
|
||||
|
||||
|
||||
-- Common
|
||||
|
||||
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
|
||||
newtype Identifier a = Identifier { name :: Name }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Identifier where liftEq = genericLiftEq
|
||||
instance Ord1 Identifier where liftCompare = genericLiftCompare
|
||||
instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
instance Evaluatable Identifier where
|
||||
eval eval ref' term@(Identifier name) = do
|
||||
-- TODO: Set the span up correctly in ref so we can move the `reference` call there.
|
||||
span <- ask @Span
|
||||
reference (Reference name) span ScopeGraph.Identifier (Declaration name)
|
||||
deref =<< ref eval ref' term
|
||||
|
||||
ref _ _ (Identifier name) = lookupSlot (Declaration name)
|
||||
|
||||
|
||||
instance FreeVariables1 Identifier where
|
||||
liftFreeVariables _ (Identifier x) = Set.singleton x
|
||||
|
||||
instance Declarations1 Identifier where
|
||||
liftDeclaredName _ (Identifier x) = pure x
|
||||
liftDeclaredAlias _ (Identifier x) = pure x
|
||||
|
||||
-- | An accessibility modifier, e.g. private, public, protected, etc.
|
||||
newtype AccessibilityModifier a = AccessibilityModifier { contents :: Text }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
|
||||
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
|
||||
instance Show1 AccessibilityModifier where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for AccessibilityModifier
|
||||
instance Evaluatable AccessibilityModifier
|
||||
|
||||
-- | Empty syntax, with essentially no-op semantics.
|
||||
--
|
||||
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
|
||||
data Empty a = Empty
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Empty where liftEq = genericLiftEq
|
||||
instance Ord1 Empty where liftCompare = genericLiftCompare
|
||||
instance Show1 Empty where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Empty where
|
||||
eval _ _ _ = unit
|
||||
|
||||
-- | Syntax representing a parsing or assignment error.
|
||||
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Error where liftEq = genericLiftEq
|
||||
instance Ord1 Error where liftCompare = genericLiftCompare
|
||||
instance Show1 Error where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Error
|
||||
|
||||
errorSyntax :: Error.Error String -> [a] -> Error a
|
||||
errorSyntax Error.Error{..} = Error (ErrorStack $ errorSite <$> getCallStack callStack) errorExpected errorActual
|
||||
|
||||
unError :: Span -> Error a -> Error.Error String
|
||||
unError span Error{..} = Error.Error span errorExpected errorActual stack
|
||||
where stack = fromCallSiteList $ unErrorSite <$> unErrorStack errorCallStack
|
||||
|
||||
data ErrorSite = ErrorSite { errorMessage :: String, errorLocation :: SrcLoc }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
errorSite :: (String, SrcLoc) -> ErrorSite
|
||||
errorSite = uncurry ErrorSite
|
||||
|
||||
unErrorSite :: ErrorSite -> (String, SrcLoc)
|
||||
unErrorSite ErrorSite{..} = (errorMessage, errorLocation)
|
||||
|
||||
newtype ErrorStack = ErrorStack { unErrorStack :: [ErrorSite] }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON ErrorStack where
|
||||
toJSON (ErrorStack es) = toJSON (jSite <$> es) where
|
||||
jSite (ErrorSite site SrcLoc{..}) = Aeson.object
|
||||
[ "site" .= site
|
||||
, "package" .= srcLocPackage
|
||||
, "module" .= srcLocModule
|
||||
, "file" .= srcLocFile
|
||||
, "startLine" .= srcLocStartLine
|
||||
, "startColumn" .= srcLocStartCol
|
||||
, "endColumn" .= srcLocEndCol
|
||||
]
|
||||
|
||||
instance Hashable ErrorStack where
|
||||
hashWithSalt = hashUsing (map (second ((,,,,,,) <$> srcLocPackage <*> srcLocModule <*> srcLocFile <*> srcLocStartLine <*> srcLocStartCol <*> srcLocEndLine <*> srcLocEndCol) . unErrorSite) . unErrorStack)
|
||||
|
||||
instance Ord ErrorStack where
|
||||
compare = liftCompare (liftCompare compareSrcLoc) `on` (fmap unErrorSite . unErrorStack)
|
||||
where compareSrcLoc s1 s2 = mconcat
|
||||
[ (compare `on` srcLocPackage) s1 s2
|
||||
, (compare `on` srcLocModule) s1 s2
|
||||
, (compare `on` srcLocFile) s1 s2
|
||||
, (compare `on` srcLocStartLine) s1 s2
|
||||
, (compare `on` srcLocStartCol) s1 s2
|
||||
, (compare `on` srcLocEndLine) s1 s2
|
||||
, (compare `on` srcLocEndCol) s1 s2
|
||||
]
|
||||
|
||||
|
||||
class HasErrors term where
|
||||
getErrors :: term Loc -> [Error.Error String]
|
||||
|
||||
instance (Error :< fs, Apply Foldable fs, Apply Functor fs) => HasErrors (Term (Sum fs)) where
|
||||
getErrors = cata $ \ (In Loc{..} syntax) ->
|
||||
maybe (fold syntax) (pure . unError span) (Data.Sum.project syntax)
|
||||
|
||||
|
||||
data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Traversable)
|
||||
|
||||
instance Eq1 Context where liftEq = genericLiftEq
|
||||
instance Ord1 Context where liftCompare = genericLiftCompare
|
||||
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Hashable1 Context where liftHashWithSalt = foldl
|
||||
|
||||
instance Evaluatable Context where
|
||||
eval eval _ Context{..} = eval contextSubject
|
||||
|
||||
instance Declarations1 Context where
|
||||
liftDeclaredName declaredName = declaredName . contextSubject
|
||||
@ -1,39 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Data.Syntax.Comment (module Data.Syntax.Comment) where
|
||||
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic1)
|
||||
|
||||
-- | An unnested comment (line or block).
|
||||
newtype Comment a = Comment { commentContent :: Text }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
instance Eq1 Comment where liftEq = genericLiftEq
|
||||
instance Ord1 Comment where liftCompare = genericLiftCompare
|
||||
instance Show1 Comment where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Comment where
|
||||
eval _ _ _ = unit
|
||||
|
||||
-- TODO: nested comment types
|
||||
-- TODO: documentation comment types
|
||||
-- TODO: literate programming comment types? alternatively, consider those as markup
|
||||
-- TODO: Differentiate between line/block comments?
|
||||
|
||||
-- | HashBang line (e.g. `#!/usr/bin/env node`)
|
||||
newtype HashBang a = HashBang { value :: Text }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
instance Eq1 HashBang where liftEq = genericLiftEq
|
||||
instance Ord1 HashBang where liftCompare = genericLiftCompare
|
||||
instance Show1 HashBang where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for HashBang
|
||||
instance Evaluatable HashBang
|
||||
@ -1,363 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Data.Syntax.Declaration (module Data.Syntax.Declaration) where
|
||||
|
||||
|
||||
import Control.Lens.Getter
|
||||
import Control.Monad
|
||||
import Data.Foldable
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe.Exts
|
||||
import qualified Data.Set as Set
|
||||
import Data.Traversable
|
||||
import GHC.Generics (Generic1)
|
||||
|
||||
import Control.Abstract hiding (AccessControl (..), Function)
|
||||
import Data.Abstract.Evaluatable
|
||||
import qualified Data.Abstract.ScopeGraph as ScopeGraph
|
||||
import Source.Span
|
||||
|
||||
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
|
||||
deriving (Foldable, Traversable, Functor, Generic1, Hashable1)
|
||||
|
||||
instance Eq1 Function where liftEq = genericLiftEq
|
||||
instance Ord1 Function where liftCompare = genericLiftCompare
|
||||
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Filter the closed-over environment by the free variables in the term.
|
||||
-- TODO: How should we represent function types, where applicable?
|
||||
|
||||
instance Evaluatable Function where
|
||||
eval _ _ Function{..} = do
|
||||
current <- ask @Span
|
||||
(name, associatedScope) <- declareFunction (declaredName functionName) ScopeGraph.Public current ScopeGraph.Function
|
||||
|
||||
params <- withScope associatedScope . for functionParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span_) ScopeGraph.Parameter Nothing
|
||||
|
||||
addr <- lookupSlot (Declaration name)
|
||||
v <- function name params functionBody associatedScope
|
||||
v <$ assign addr v
|
||||
|
||||
declareFunction :: ( Has (State (ScopeGraph address)) sig m
|
||||
, Has (Allocator address) sig m
|
||||
, Has (Reader (CurrentScope address)) sig m
|
||||
, Has (Reader ModuleInfo) sig m
|
||||
, Has Fresh sig m
|
||||
, Ord address
|
||||
)
|
||||
=> Maybe Name
|
||||
-> ScopeGraph.AccessControl
|
||||
-> Span
|
||||
-> ScopeGraph.Kind
|
||||
-> Evaluator term address value m (Name, address)
|
||||
declareFunction name accessControl span kind = do
|
||||
currentScope' <- currentScope
|
||||
let lexicalEdges = Map.singleton Lexical [ currentScope' ]
|
||||
associatedScope <- newScope lexicalEdges
|
||||
name' <- declareMaybeName name Default accessControl span kind (Just associatedScope)
|
||||
pure (name', associatedScope)
|
||||
|
||||
|
||||
instance Declarations1 Function where
|
||||
liftDeclaredName declaredName = declaredName . functionName
|
||||
|
||||
instance FreeVariables1 Function where
|
||||
liftFreeVariables freeVariables f@Function{..} = foldMap freeVariables f `Set.difference` foldMap freeVariables functionParameters
|
||||
|
||||
data Method a = Method
|
||||
{ methodContext :: [a]
|
||||
, methodReceiver :: a
|
||||
, methodName :: a
|
||||
, methodParameters :: [a]
|
||||
, methodBody :: a
|
||||
, methodAccessControl :: ScopeGraph.AccessControl
|
||||
}
|
||||
deriving (Foldable, Traversable, Functor, Generic1, Hashable1)
|
||||
|
||||
instance Eq1 Method where liftEq = genericLiftEq
|
||||
instance Ord1 Method where liftCompare = genericLiftCompare
|
||||
instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- Evaluating a Method creates a closure and makes that value available in the
|
||||
-- local environment.
|
||||
instance Evaluatable Method where
|
||||
eval _ _ Method{..} = do
|
||||
current <- ask @Span
|
||||
(name, associatedScope) <- declareFunction (declaredName methodName) methodAccessControl current ScopeGraph.Method
|
||||
|
||||
params <- withScope associatedScope $ do
|
||||
-- TODO: Should we give `self` a special Relation?
|
||||
declare (Declaration __self) ScopeGraph.Prelude ScopeGraph.Public (point (Pos 1 1)) ScopeGraph.Unknown Nothing
|
||||
for methodParameters $ \paramNode -> declareMaybeName (declaredName paramNode) Default ScopeGraph.Public (paramNode^.span_) ScopeGraph.Parameter Nothing
|
||||
|
||||
addr <- lookupSlot (Declaration name)
|
||||
v <- function name params methodBody associatedScope
|
||||
v <$ assign addr v
|
||||
|
||||
instance Declarations1 Method where
|
||||
liftDeclaredName declaredName = declaredName . methodName
|
||||
|
||||
instance FreeVariables1 Method where
|
||||
liftFreeVariables freeVariables m@Method{..} = foldMap freeVariables m `Set.difference` foldMap freeVariables methodParameters
|
||||
|
||||
|
||||
-- | A method signature in TypeScript or a method spec in Go.
|
||||
data MethodSignature a = MethodSignature
|
||||
{ methodSignatureContext :: [a]
|
||||
, methodSignatureName :: a
|
||||
, methodSignatureParameters :: [a]
|
||||
, methodSignatureAccessControl :: ScopeGraph.AccessControl
|
||||
}
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 MethodSignature where liftEq = genericLiftEq
|
||||
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
|
||||
instance Show1 MethodSignature where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for MethodSignature
|
||||
instance Evaluatable MethodSignature
|
||||
|
||||
|
||||
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 RequiredParameter where liftEq = genericLiftEq
|
||||
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
|
||||
instance Show1 RequiredParameter where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations1 RequiredParameter where
|
||||
liftDeclaredName declaredName = declaredName . requiredParameter
|
||||
|
||||
-- TODO: Implement Eval instance for RequiredParameter
|
||||
instance Evaluatable RequiredParameter where
|
||||
eval _ _ RequiredParameter{..} = do
|
||||
span <- ask @Span
|
||||
_ <- declareMaybeName (declaredName requiredParameter) Default ScopeGraph.Public span ScopeGraph.RequiredParameter Nothing
|
||||
unit
|
||||
|
||||
|
||||
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 OptionalParameter where liftEq = genericLiftEq
|
||||
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
|
||||
instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for OptionalParameter
|
||||
instance Evaluatable OptionalParameter
|
||||
|
||||
|
||||
-- TODO: Should we replace this with Function and differentiate by context?
|
||||
-- TODO: How should we distinguish class/instance methods?
|
||||
-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
|
||||
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
|
||||
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 VariableDeclaration where liftEq = genericLiftEq
|
||||
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
|
||||
instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable VariableDeclaration where
|
||||
eval _ _ (VariableDeclaration []) = unit
|
||||
eval eval _ (VariableDeclaration decs) = do
|
||||
for_ decs $ \declaration -> do
|
||||
_ <- declareMaybeName (declaredName declaration) Default ScopeGraph.Public (declaration^.span_) ScopeGraph.VariableDeclaration Nothing
|
||||
eval declaration
|
||||
unit
|
||||
|
||||
instance Declarations a => Declarations (VariableDeclaration a) where
|
||||
declaredName (VariableDeclaration vars) = case vars of
|
||||
[var] -> declaredName var
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
-- | A TypeScript/Java style interface declaration to implement.
|
||||
|
||||
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationSuperInterfaces :: ![a], interfaceDeclarationBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
|
||||
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
|
||||
instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for InterfaceDeclaration
|
||||
instance Evaluatable InterfaceDeclaration
|
||||
|
||||
instance Declarations a => Declarations (InterfaceDeclaration a) where
|
||||
declaredName InterfaceDeclaration{..} = declaredName interfaceDeclarationIdentifier
|
||||
|
||||
|
||||
-- | A public field definition such as a field definition in a JavaScript class.
|
||||
data PublicFieldDefinition a = PublicFieldDefinition
|
||||
{ publicFieldContext :: [a]
|
||||
, publicFieldPropertyName :: a
|
||||
, publicFieldValue :: a
|
||||
, publicFieldAccessControl :: ScopeGraph.AccessControl
|
||||
}
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
|
||||
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
|
||||
instance Show1 PublicFieldDefinition where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for PublicFieldDefinition
|
||||
instance Evaluatable PublicFieldDefinition where
|
||||
eval eval _ PublicFieldDefinition{..} = do
|
||||
span <- ask @Span
|
||||
name <- declareMaybeName (declaredName publicFieldPropertyName) Instance publicFieldAccessControl span ScopeGraph.PublicField Nothing
|
||||
slot <- lookupSlot (Declaration name)
|
||||
value <- eval publicFieldValue
|
||||
assign slot value
|
||||
unit
|
||||
|
||||
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Variable where liftEq = genericLiftEq
|
||||
instance Ord1 Variable where liftCompare = genericLiftCompare
|
||||
instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Variable
|
||||
instance Evaluatable Variable
|
||||
|
||||
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
|
||||
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1)
|
||||
|
||||
instance Eq1 Class where liftEq = genericLiftEq
|
||||
instance Ord1 Class where liftCompare = genericLiftCompare
|
||||
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations a => Declarations (Class a) where
|
||||
declaredName (Class _ name _ _) = declaredName name
|
||||
|
||||
instance Evaluatable Class where
|
||||
eval eval _ Class{..} = do
|
||||
span <- ask @Span
|
||||
currentScope' <- currentScope
|
||||
|
||||
superScopes <- for classSuperclasses $ \superclass -> do
|
||||
name <- maybeM gensym (declaredName superclass)
|
||||
scope <- associatedScope (Declaration name)
|
||||
slot <- lookupSlot (Declaration name)
|
||||
superclassFrame <- scopedEnvironment =<< deref slot
|
||||
pure $ case (scope, superclassFrame) of
|
||||
(Just scope, Just frame) -> Just (scope, frame)
|
||||
_ -> Nothing
|
||||
|
||||
let superclassEdges = (Superclass, ) . pure . fst <$> catMaybes superScopes
|
||||
current = (Lexical, ) <$> pure (pure currentScope')
|
||||
edges = Map.fromList (superclassEdges <> current)
|
||||
classScope <- newScope edges
|
||||
name <- declareMaybeName (declaredName classIdentifier) Default ScopeGraph.Public span ScopeGraph.Class (Just classScope)
|
||||
|
||||
let frameEdges = Map.singleton Superclass (Map.fromList (catMaybes superScopes))
|
||||
classFrame <- newFrame classScope frameEdges
|
||||
|
||||
classSlot <- lookupSlot (Declaration name)
|
||||
assign classSlot =<< klass (Declaration name) classFrame
|
||||
|
||||
withScopeAndFrame classFrame $ do
|
||||
void $ eval classBody
|
||||
|
||||
unit
|
||||
|
||||
instance Declarations1 Class where
|
||||
liftDeclaredName declaredName = declaredName . classIdentifier
|
||||
|
||||
-- | A decorator in Python
|
||||
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Decorator where liftEq = genericLiftEq
|
||||
instance Ord1 Decorator where liftCompare = genericLiftCompare
|
||||
instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Decorator
|
||||
instance Evaluatable Decorator
|
||||
|
||||
-- TODO: Generics, constraints.
|
||||
|
||||
|
||||
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
|
||||
data Datatype a = Datatype { datatypeContext :: a, datatypeName :: a, datatypeConstructors :: [a], datatypeDeriving :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Datatype where liftEq = genericLiftEq
|
||||
instance Ord1 Datatype where liftCompare = genericLiftCompare
|
||||
instance Show1 Datatype where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Datatype
|
||||
instance Evaluatable Data.Syntax.Declaration.Datatype
|
||||
|
||||
|
||||
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
|
||||
data Constructor a = Constructor { constructorContext :: [a], constructorName :: a, constructorFields :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Constructor where liftEq = genericLiftEq
|
||||
instance Ord1 Constructor where liftCompare = genericLiftCompare
|
||||
instance Show1 Constructor where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Constructor
|
||||
instance Evaluatable Data.Syntax.Declaration.Constructor
|
||||
|
||||
|
||||
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
|
||||
data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Comprehension where liftEq = genericLiftEq
|
||||
instance Ord1 Comprehension where liftCompare = genericLiftCompare
|
||||
instance Show1 Comprehension where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Comprehension
|
||||
instance Evaluatable Comprehension
|
||||
|
||||
|
||||
-- | A declared type (e.g. `a []int` in Go).
|
||||
data Type a = Type { typeName :: !a, typeKind :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Type where liftEq = genericLiftEq
|
||||
instance Ord1 Type where liftCompare = genericLiftCompare
|
||||
instance Show1 Type where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Type
|
||||
instance Evaluatable Type
|
||||
|
||||
|
||||
-- | Type alias declarations in Javascript/Haskell, etc.
|
||||
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 TypeAlias where liftEq = genericLiftEq
|
||||
instance Ord1 TypeAlias where liftCompare = genericLiftCompare
|
||||
instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable TypeAlias where
|
||||
eval _ _ TypeAlias{..} = do
|
||||
-- This use of `throwNoNameError` is good -- we aren't declaring something new so `declareMaybeName` is not useful here.
|
||||
kindName <- maybeM (throwNoNameError typeAliasKind) (declaredName typeAliasKind)
|
||||
span <- ask @Span
|
||||
assocScope <- associatedScope (Declaration kindName)
|
||||
name <- declareMaybeName (declaredName typeAliasIdentifier) Default ScopeGraph.Public span ScopeGraph.TypeAlias assocScope
|
||||
|
||||
slot <- lookupSlot (Declaration name)
|
||||
kindSlot <- lookupSlot (Declaration kindName)
|
||||
assign slot =<< deref kindSlot
|
||||
|
||||
unit
|
||||
|
||||
instance Declarations a => Declarations (TypeAlias a) where
|
||||
declaredName TypeAlias{..} = declaredName typeAliasIdentifier
|
||||
@ -1,39 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Data.Syntax.Directive (module Data.Syntax.Directive) where
|
||||
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Module (ModuleInfo (..))
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic1)
|
||||
import Source.Span
|
||||
import qualified System.Path as Path
|
||||
|
||||
-- A file directive like the Ruby constant `__FILE__`.
|
||||
data File a = File
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 File where liftEq = genericLiftEq
|
||||
instance Ord1 File where liftCompare = genericLiftCompare
|
||||
instance Show1 File where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable File where
|
||||
eval _ _ File = currentModule >>= string . T.pack . Path.toString . modulePath
|
||||
|
||||
|
||||
-- A line directive like the Ruby constant `__LINE__`.
|
||||
data Line a = Line
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Line where liftEq = genericLiftEq
|
||||
instance Ord1 Line where liftCompare = genericLiftCompare
|
||||
instance Show1 Line where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Line where
|
||||
eval _ _ Line = currentSpan >>= integer . fromIntegral . line . start
|
||||
@ -1,642 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Data.Syntax.Expression (module Data.Syntax.Expression) where
|
||||
|
||||
import Prelude hiding (null)
|
||||
|
||||
import Analysis.Name as Name
|
||||
import Control.Abstract hiding (Bitwise (..), Call, Void)
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.Abstract.Evaluatable as Abstract
|
||||
import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv)
|
||||
import qualified Data.Abstract.ScopeGraph as ScopeGraph
|
||||
import Data.Bits
|
||||
import Data.Fixed
|
||||
import Data.Foldable (for_)
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import Data.List (find)
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe
|
||||
import Data.Maybe.Exts
|
||||
import GHC.Generics (Generic1)
|
||||
|
||||
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
|
||||
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Call where liftEq = genericLiftEq
|
||||
instance Ord1 Call where liftCompare = genericLiftCompare
|
||||
instance Show1 Call where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations1 Call where
|
||||
liftDeclaredName declaredName Call{..} = declaredName callFunction
|
||||
|
||||
instance Evaluatable Call where
|
||||
eval eval _ Call{..} = do
|
||||
op <- eval callFunction
|
||||
args <- traverse eval callParams
|
||||
call op args
|
||||
|
||||
data LessThan a = LessThan { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 LessThan where liftEq = genericLiftEq
|
||||
instance Ord1 LessThan where liftCompare = genericLiftCompare
|
||||
instance Show1 LessThan where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable LessThan where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (LessThan a b) = liftComparison (Concrete (<)) a b
|
||||
|
||||
data LessThanEqual a = LessThanEqual { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 LessThanEqual where liftEq = genericLiftEq
|
||||
instance Ord1 LessThanEqual where liftCompare = genericLiftCompare
|
||||
instance Show1 LessThanEqual where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable LessThanEqual where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (LessThanEqual a b) = liftComparison (Concrete (<=)) a b
|
||||
|
||||
data GreaterThan a = GreaterThan { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 GreaterThan where liftEq = genericLiftEq
|
||||
instance Ord1 GreaterThan where liftCompare = genericLiftCompare
|
||||
instance Show1 GreaterThan where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable GreaterThan where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (GreaterThan a b) = liftComparison (Concrete (>)) a b
|
||||
|
||||
data GreaterThanEqual a = GreaterThanEqual { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 GreaterThanEqual where liftEq = genericLiftEq
|
||||
instance Ord1 GreaterThanEqual where liftCompare = genericLiftCompare
|
||||
instance Show1 GreaterThanEqual where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable GreaterThanEqual where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (GreaterThanEqual a b) = liftComparison (Concrete (>=)) a b
|
||||
|
||||
data Equal a = Equal { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Equal where liftEq = genericLiftEq
|
||||
instance Ord1 Equal where liftCompare = genericLiftCompare
|
||||
instance Show1 Equal where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Equal where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
-- TODO: in PHP and JavaScript, the equals operator performs type coercion.
|
||||
-- We need some mechanism to customize this behavior per-language.
|
||||
go (Equal a b) = liftComparison (Concrete (==)) a b
|
||||
|
||||
data StrictEqual a = StrictEqual { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 StrictEqual where liftEq = genericLiftEq
|
||||
instance Ord1 StrictEqual where liftCompare = genericLiftCompare
|
||||
instance Show1 StrictEqual where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable StrictEqual where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
-- TODO: in PHP and JavaScript, the equals operator performs type coercion.
|
||||
-- We need some mechanism to customize this behavior per-language.
|
||||
go (StrictEqual a b) = liftComparison (Concrete (==)) a b
|
||||
|
||||
data Comparison a = Comparison { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Comparison where liftEq = genericLiftEq
|
||||
instance Ord1 Comparison where liftCompare = genericLiftCompare
|
||||
instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Comparison where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Comparison a b) = liftComparison (Concrete (==)) a b
|
||||
|
||||
data Plus a = Plus { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Plus where liftEq = genericLiftEq
|
||||
instance Ord1 Plus where liftCompare = genericLiftCompare
|
||||
instance Show1 Plus where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Plus where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
|
||||
|
||||
data Minus a = Minus { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Minus where liftEq = genericLiftEq
|
||||
instance Ord1 Minus where liftCompare = genericLiftCompare
|
||||
instance Show1 Minus where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Minus where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Minus a b) = liftNumeric2 (liftReal (-)) a b
|
||||
|
||||
data Times a = Times { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Times where liftEq = genericLiftEq
|
||||
instance Ord1 Times where liftCompare = genericLiftCompare
|
||||
instance Show1 Times where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Times where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Times a b) = liftNumeric2 (liftReal (*)) a b
|
||||
|
||||
data DividedBy a = DividedBy { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 DividedBy where liftEq = genericLiftEq
|
||||
instance Ord1 DividedBy where liftCompare = genericLiftCompare
|
||||
instance Show1 DividedBy where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable DividedBy where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (DividedBy a b) = liftNumeric2 (liftIntegralFrac div (/)) a b
|
||||
|
||||
data Modulo a = Modulo { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Modulo where liftEq = genericLiftEq
|
||||
instance Ord1 Modulo where liftCompare = genericLiftCompare
|
||||
instance Show1 Modulo where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Modulo where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Modulo a b) = liftNumeric2 (liftIntegralFrac mod mod') a b
|
||||
|
||||
data Power a = Power { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Power where liftEq = genericLiftEq
|
||||
instance Ord1 Power where liftCompare = genericLiftCompare
|
||||
instance Show1 Power where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Power where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Power a b) = liftNumeric2 liftedExponent a b
|
||||
|
||||
newtype Negate a = Negate { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Negate where liftEq = genericLiftEq
|
||||
instance Ord1 Negate where liftCompare = genericLiftCompare
|
||||
instance Show1 Negate where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Negate where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (Negate a) = liftNumeric negate a
|
||||
|
||||
data FloorDivision a = FloorDivision { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 FloorDivision where liftEq = genericLiftEq
|
||||
instance Ord1 FloorDivision where liftCompare = genericLiftCompare
|
||||
instance Show1 FloorDivision where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable FloorDivision where
|
||||
eval eval _ t = traverse eval t >>= go where
|
||||
go (FloorDivision a b) = liftNumeric2 liftedFloorDiv a b
|
||||
|
||||
-- | Regex matching operators (Ruby's =~ and ~!)
|
||||
data Matches a = Matches { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Matches where liftEq = genericLiftEq
|
||||
instance Ord1 Matches where liftCompare = genericLiftCompare
|
||||
instance Show1 Matches where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Matches
|
||||
|
||||
data NotMatches a = NotMatches { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 NotMatches where liftEq = genericLiftEq
|
||||
instance Ord1 NotMatches where liftCompare = genericLiftCompare
|
||||
instance Show1 NotMatches where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable NotMatches
|
||||
|
||||
data Or a = Or { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Or where liftEq = genericLiftEq
|
||||
instance Ord1 Or where liftCompare = genericLiftCompare
|
||||
instance Show1 Or where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Or where
|
||||
eval eval _ (Or a b) = do
|
||||
a' <- eval a
|
||||
ifthenelse a' (pure a') (eval b)
|
||||
|
||||
data And a = And { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 And where liftEq = genericLiftEq
|
||||
instance Ord1 And where liftCompare = genericLiftCompare
|
||||
instance Show1 And where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable And where
|
||||
eval eval _ (And a b) = do
|
||||
a' <- eval a
|
||||
ifthenelse a' (eval b) (pure a')
|
||||
|
||||
newtype Not a = Not { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Not where liftEq = genericLiftEq
|
||||
instance Ord1 Not where liftCompare = genericLiftCompare
|
||||
instance Show1 Not where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Not where
|
||||
eval eval _ (Not a) = eval a >>= asBool >>= boolean . not
|
||||
|
||||
data XOr a = XOr { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 XOr where liftEq = genericLiftEq
|
||||
instance Ord1 XOr where liftCompare = genericLiftCompare
|
||||
instance Show1 XOr where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable XOr where
|
||||
-- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
|
||||
eval eval _ (XOr a b) = liftA2 (/=) (eval a >>= asBool) (eval b >>= asBool) >>= boolean
|
||||
|
||||
-- | Javascript delete operator
|
||||
newtype Delete a = Delete { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Delete where liftEq = genericLiftEq
|
||||
instance Ord1 Delete where liftCompare = genericLiftCompare
|
||||
instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Delete where
|
||||
eval _ ref (Delete a) = ref a >>= dealloc >> unit
|
||||
|
||||
-- | A sequence expression such as Javascript or C's comma operator.
|
||||
data SequenceExpression a = SequenceExpression { firstExpression :: !a, secondExpression :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 SequenceExpression where liftEq = genericLiftEq
|
||||
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
|
||||
instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable SequenceExpression where
|
||||
eval eval _ (SequenceExpression a b) =
|
||||
eval a >> eval b
|
||||
|
||||
-- | Javascript void operator
|
||||
newtype Void a = Void { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Void where liftEq = genericLiftEq
|
||||
instance Ord1 Void where liftCompare = genericLiftCompare
|
||||
instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Void where
|
||||
eval eval _ (Void a) =
|
||||
eval a >> pure null
|
||||
|
||||
-- | Javascript typeof operator
|
||||
newtype Typeof a = Typeof { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Typeof where liftEq = genericLiftEq
|
||||
instance Ord1 Typeof where liftCompare = genericLiftCompare
|
||||
instance Show1 Typeof where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Typeof
|
||||
instance Evaluatable Typeof
|
||||
|
||||
-- | Bitwise operators.
|
||||
data BOr a = BOr { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 BOr where liftEq = genericLiftEq
|
||||
instance Ord1 BOr where liftCompare = genericLiftCompare
|
||||
instance Show1 BOr where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable BOr where
|
||||
eval eval _ (BOr a b) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
b' <- eval b >>= castToInteger
|
||||
liftBitwise2 (.|.) a' b'
|
||||
|
||||
data BAnd a = BAnd { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 BAnd where liftEq = genericLiftEq
|
||||
instance Ord1 BAnd where liftCompare = genericLiftCompare
|
||||
instance Show1 BAnd where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable BAnd where
|
||||
eval eval _ (BAnd a b) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
b' <- eval b >>= castToInteger
|
||||
liftBitwise2 (.&.) a' b'
|
||||
|
||||
data BXOr a = BXOr { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 BXOr where liftEq = genericLiftEq
|
||||
instance Ord1 BXOr where liftCompare = genericLiftCompare
|
||||
instance Show1 BXOr where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable BXOr where
|
||||
eval eval _ (BXOr a b) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
b' <- eval b >>= castToInteger
|
||||
liftBitwise2 xor a' b'
|
||||
|
||||
data LShift a = LShift { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 LShift where liftEq = genericLiftEq
|
||||
instance Ord1 LShift where liftCompare = genericLiftCompare
|
||||
instance Show1 LShift where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable LShift where
|
||||
eval eval _ (LShift a b) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
b' <- eval b >>= castToInteger
|
||||
liftBitwise2 shiftL' a' b'
|
||||
where
|
||||
shiftL' a b = shiftL a (fromIntegral (toInteger b))
|
||||
|
||||
data RShift a = RShift { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 RShift where liftEq = genericLiftEq
|
||||
instance Ord1 RShift where liftCompare = genericLiftCompare
|
||||
instance Show1 RShift where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable RShift where
|
||||
eval eval _ (RShift a b) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
b' <- eval b >>= castToInteger
|
||||
liftBitwise2 shiftR' a' b'
|
||||
where
|
||||
shiftR' a b = shiftR a (fromIntegral (toInteger b))
|
||||
|
||||
data UnsignedRShift a = UnsignedRShift { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 UnsignedRShift where liftEq = genericLiftEq
|
||||
instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare
|
||||
instance Show1 UnsignedRShift where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable UnsignedRShift where
|
||||
eval eval _ (UnsignedRShift a b) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
b' <- eval b >>= castToInteger
|
||||
unsignedRShift a' b'
|
||||
|
||||
newtype Complement a = Complement { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Complement where liftEq = genericLiftEq
|
||||
instance Ord1 Complement where liftCompare = genericLiftCompare
|
||||
instance Show1 Complement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Complement where
|
||||
eval eval _ (Complement a) = do
|
||||
a' <- eval a >>= castToInteger
|
||||
liftBitwise complement a'
|
||||
|
||||
-- | Member Access (e.g. a.b)
|
||||
data MemberAccess a = MemberAccess { lhs :: a, rhs :: a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 MemberAccess where liftEq = genericLiftEq
|
||||
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
|
||||
instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations1 MemberAccess where
|
||||
liftDeclaredName declaredName MemberAccess{..} = declaredName rhs
|
||||
|
||||
instance Evaluatable MemberAccess where
|
||||
eval eval ref MemberAccess{..} = do
|
||||
lhsValue <- eval lhs
|
||||
lhsFrame <- Abstract.scopedEnvironment lhsValue
|
||||
|
||||
rhsSlot <- case lhsFrame of
|
||||
Just lhsFrame ->
|
||||
-- FIXME: The span is not set up correctly when calling `ref` so we have to eval
|
||||
-- it first
|
||||
withScopeAndFrame lhsFrame (eval rhs >> ref rhs)
|
||||
-- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object.
|
||||
Nothing -> throwEvalError (ReferenceError lhsValue rhs)
|
||||
|
||||
rhsValue <- deref rhsSlot
|
||||
rhsScope <- scopeLookup (frameAddress rhsSlot)
|
||||
|
||||
let lhsAccessControl = fromMaybe Public (termToAccessControl lhs)
|
||||
infos <- declarationsByAccessControl rhsScope lhsAccessControl
|
||||
|
||||
-- This means we always throw an 'AccessControlError' whenever we have a rhs term whose 'declaredName' is 'Nothing'.
|
||||
rhsName <- maybeM (throwNoNameError rhs) (declaredName rhs)
|
||||
rhsValue' <- case find (\Info{..} -> Declaration rhsName == infoDeclaration) infos of
|
||||
Just _ -> pure rhsValue
|
||||
Nothing -> do
|
||||
let lhsName = fromMaybe (name "") (declaredName lhs)
|
||||
info <- declarationByName rhsScope (Declaration rhsName)
|
||||
throwEvalError $ AccessControlError (lhsName, lhsAccessControl) (rhsName, infoAccessControl info) rhsValue
|
||||
|
||||
bindThis lhsValue rhsValue'
|
||||
|
||||
|
||||
ref eval ref' MemberAccess{..} = do
|
||||
lhsValue <- eval lhs
|
||||
lhsFrame <- Abstract.scopedEnvironment lhsValue
|
||||
case lhsFrame of
|
||||
Just lhsFrame -> withScopeAndFrame lhsFrame (ref' rhs)
|
||||
-- Throw a ReferenceError since we're attempting to reference a name within a value that is not an Object.
|
||||
Nothing -> throwEvalError (ReferenceError lhsValue rhs)
|
||||
|
||||
|
||||
-- | Subscript (e.g a[1])
|
||||
data Subscript a = Subscript { lhs :: a, rhs :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Subscript where liftEq = genericLiftEq
|
||||
instance Ord1 Subscript where liftCompare = genericLiftCompare
|
||||
instance Show1 Subscript where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Finish Eval instance for Subscript
|
||||
-- TODO return a special LvalSubscript instance here
|
||||
instance Evaluatable Subscript where
|
||||
eval eval _ (Subscript l [r]) = join (index <$> eval l <*> eval r)
|
||||
eval _ _ (Subscript _ _) = throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices")
|
||||
|
||||
data Member a = Member { lhs :: a, rhs :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Member where liftEq = genericLiftEq
|
||||
instance Ord1 Member where liftCompare = genericLiftCompare
|
||||
instance Show1 Member where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Member where
|
||||
|
||||
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
|
||||
data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Enumeration where liftEq = genericLiftEq
|
||||
instance Ord1 Enumeration where liftCompare = genericLiftCompare
|
||||
instance Show1 Enumeration where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Enumeration
|
||||
instance Evaluatable Enumeration
|
||||
|
||||
-- | InstanceOf (e.g. a instanceof b in JavaScript
|
||||
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 InstanceOf where liftEq = genericLiftEq
|
||||
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
|
||||
instance Show1 InstanceOf where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for InstanceOf
|
||||
instance Evaluatable InstanceOf
|
||||
|
||||
|
||||
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
|
||||
newtype ScopeResolution a = ScopeResolution { scopes :: NonEmpty a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Traversable)
|
||||
|
||||
instance Eq1 ScopeResolution where liftEq = genericLiftEq
|
||||
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
|
||||
instance Show1 ScopeResolution where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Hashable1 ScopeResolution where liftHashWithSalt = foldl
|
||||
|
||||
instance Evaluatable ScopeResolution
|
||||
|
||||
instance Declarations1 ScopeResolution where
|
||||
liftDeclaredName declaredName = declaredName . NonEmpty.last . scopes
|
||||
|
||||
-- | A non-null expression such as Typescript or Swift's ! expression.
|
||||
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 NonNullExpression where liftEq = genericLiftEq
|
||||
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
|
||||
instance Show1 NonNullExpression where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for NonNullExpression
|
||||
instance Evaluatable NonNullExpression
|
||||
|
||||
|
||||
-- | An await expression in Javascript or C#.
|
||||
newtype Await a = Await { awaitSubject :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Await where liftEq = genericLiftEq
|
||||
instance Ord1 Await where liftCompare = genericLiftCompare
|
||||
instance Show1 Await where liftShowsPrec = genericLiftShowsPrec
|
||||
-- TODO: Improve this to model asynchrony or capture some data suggesting async calls are not a problem.
|
||||
-- We are currently dealing with an asynchronous construct synchronously.
|
||||
instance Evaluatable Await where
|
||||
eval eval _ (Await a) = eval a
|
||||
|
||||
-- | An object constructor call in Javascript, Java, etc.
|
||||
data New a = New { newSubject :: a , newTypeParameters :: a, newArguments :: [a] }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 New where liftEq = genericLiftEq
|
||||
instance Ord1 New where liftCompare = genericLiftCompare
|
||||
instance Show1 New where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations1 New where
|
||||
liftDeclaredName declaredName New{..} = declaredName newSubject
|
||||
|
||||
-- TODO: Implement Eval instance for New
|
||||
instance Evaluatable New where
|
||||
eval eval _ New{..} = do
|
||||
name <- maybeM (throwNoNameError newSubject) (declaredName newSubject)
|
||||
assocScope <- maybeM (throwEvalError $ ConstructorError name) =<< associatedScope (Declaration name)
|
||||
objectScope <- newScope (Map.singleton Superclass [ assocScope ])
|
||||
slot <- lookupSlot (Declaration name)
|
||||
classVal <- deref slot
|
||||
classFrame <- maybeM (throwEvalError $ ScopedEnvError classVal) =<< scopedEnvironment classVal
|
||||
|
||||
objectFrame <- newFrame objectScope (Map.singleton Superclass $ Map.singleton assocScope classFrame)
|
||||
objectVal <- object objectFrame
|
||||
|
||||
classScope <- scopeLookup classFrame
|
||||
instanceMembers <- declarationsByRelation classScope Instance
|
||||
|
||||
void . withScopeAndFrame objectFrame $ do
|
||||
for_ instanceMembers $ \Info{..} -> do
|
||||
declare infoDeclaration Default infoAccessControl infoSpan infoKind infoAssociatedScope
|
||||
|
||||
-- TODO: This is a typescript specific name and we should allow languages to customize it.
|
||||
let constructorName = Name.name "constructor"
|
||||
maybeConstructor <- maybeLookupDeclaration (Declaration constructorName)
|
||||
case maybeConstructor of
|
||||
Just slot -> do
|
||||
span <- ask @Span
|
||||
reference (Reference constructorName) span ScopeGraph.New (Declaration constructorName)
|
||||
constructor <- deref slot
|
||||
args <- traverse eval newArguments
|
||||
boundConstructor <- bindThis objectVal constructor
|
||||
call boundConstructor args
|
||||
Nothing -> pure objectVal
|
||||
|
||||
pure objectVal
|
||||
|
||||
-- | A cast expression to a specified type.
|
||||
data Cast a = Cast { castSubject :: !a, castType :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Cast where liftEq = genericLiftEq
|
||||
instance Ord1 Cast where liftCompare = genericLiftCompare
|
||||
instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Cast
|
||||
|
||||
data Super a = Super
|
||||
deriving (Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, Hashable1)
|
||||
|
||||
instance Eq1 Super where liftEq = genericLiftEq
|
||||
instance Ord1 Super where liftCompare = genericLiftCompare
|
||||
instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Super
|
||||
|
||||
data This a = This
|
||||
deriving (Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, Hashable1)
|
||||
|
||||
instance Eq1 This where liftEq = genericLiftEq
|
||||
instance Ord1 This where liftCompare = genericLiftCompare
|
||||
instance Show1 This where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable This where
|
||||
eval _ _ This = do
|
||||
span <- ask @Span
|
||||
reference (Reference __self) span ScopeGraph.This (Declaration __self)
|
||||
deref =<< lookupSlot (Declaration __self)
|
||||
|
||||
instance AccessControls1 This where
|
||||
liftTermToAccessControl _ _ = Just Private
|
||||
@ -1,285 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Data.Syntax.Literal (module Data.Syntax.Literal) where
|
||||
|
||||
import Prelude hiding (Float, null)
|
||||
|
||||
import Control.Monad
|
||||
import Data.Abstract.Evaluatable as Eval
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import Data.Scientific.Exts
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic1)
|
||||
import Numeric.Exts
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
-- Boolean
|
||||
|
||||
newtype Boolean a = Boolean { booleanContent :: Bool }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Boolean where liftEq = genericLiftEq
|
||||
instance Ord1 Boolean where liftCompare = genericLiftCompare
|
||||
instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
true :: Boolean a
|
||||
true = Boolean True
|
||||
|
||||
false :: Boolean a
|
||||
false = Boolean False
|
||||
|
||||
instance Evaluatable Boolean where
|
||||
eval _ _ (Boolean x) = boolean x
|
||||
|
||||
-- | A literal integer of unspecified width. No particular base is implied.
|
||||
newtype Integer a = Integer { integerContent :: Text }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
|
||||
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
|
||||
instance Show1 Data.Syntax.Literal.Integer where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Data.Syntax.Literal.Integer where
|
||||
-- TODO: We should use something more robust than shelling out to readMaybe.
|
||||
eval _ _ (Data.Syntax.Literal.Integer x) =
|
||||
either (const (throwEvalError (IntegerFormatError x))) pure (parseInteger x) >>= integer
|
||||
|
||||
-- | A literal float of unspecified width.
|
||||
|
||||
newtype Float a = Float { floatContent :: Text }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
|
||||
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
|
||||
instance Show1 Data.Syntax.Literal.Float where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
|
||||
instance Evaluatable Data.Syntax.Literal.Float where
|
||||
eval _ _ (Float s) =
|
||||
either (const (throwEvalError (FloatFormatError s))) pure (parseScientific s) >>= float
|
||||
|
||||
-- Rational literals e.g. `2/3r`
|
||||
newtype Rational a = Rational { value :: Text }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
|
||||
instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare
|
||||
instance Show1 Data.Syntax.Literal.Rational where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Data.Syntax.Literal.Rational where
|
||||
eval _ _ (Rational r) =
|
||||
let
|
||||
trimmed = T.takeWhile (/= 'r') r
|
||||
parsed = readMaybe @Prelude.Integer (T.unpack trimmed)
|
||||
in maybe (throwEvalError (RationalFormatError r)) (pure . toRational) parsed >>= rational
|
||||
|
||||
-- Complex literals e.g. `3 + 2i`
|
||||
newtype Complex a = Complex { value :: Text }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
instance Eq1 Complex where liftEq = genericLiftEq
|
||||
instance Ord1 Complex where liftCompare = genericLiftCompare
|
||||
instance Show1 Complex where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Complex
|
||||
instance Evaluatable Complex
|
||||
|
||||
-- Strings, symbols
|
||||
|
||||
newtype String a = String { stringElements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
|
||||
instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
|
||||
instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Should string literal bodies include escapes too?
|
||||
|
||||
-- TODO: Implement Eval instance for String
|
||||
instance Evaluatable Data.Syntax.Literal.String
|
||||
|
||||
newtype Character a = Character { characterContent :: Text }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Character where liftEq = genericLiftEq
|
||||
instance Ord1 Character where liftCompare = genericLiftCompare
|
||||
instance Show1 Character where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Data.Syntax.Literal.Character
|
||||
|
||||
-- | An interpolation element within a string literal.
|
||||
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 InterpolationElement where liftEq = genericLiftEq
|
||||
instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
|
||||
instance Show1 InterpolationElement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for InterpolationElement
|
||||
instance Evaluatable InterpolationElement
|
||||
|
||||
-- | A sequence of textual contents within a string literal.
|
||||
newtype TextElement a = TextElement { textElementContent :: Text }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
instance Eq1 TextElement where liftEq = genericLiftEq
|
||||
instance Ord1 TextElement where liftCompare = genericLiftCompare
|
||||
instance Show1 TextElement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable TextElement where
|
||||
eval _ _ (TextElement x) = string x
|
||||
|
||||
isTripleQuoted :: TextElement a -> Bool
|
||||
isTripleQuoted (TextElement t) =
|
||||
let trip = "\"\"\""
|
||||
in T.take 3 t == trip && T.takeEnd 3 t == trip
|
||||
|
||||
quoted :: Text -> TextElement a
|
||||
quoted t = TextElement ("\"" <> t <> "\"")
|
||||
|
||||
-- | A sequence of textual contents within a string literal.
|
||||
newtype EscapeSequence a = EscapeSequence { value :: Text }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
instance Eq1 EscapeSequence where liftEq = genericLiftEq
|
||||
instance Ord1 EscapeSequence where liftCompare = genericLiftCompare
|
||||
instance Show1 EscapeSequence where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for EscapeSequence
|
||||
instance Evaluatable EscapeSequence
|
||||
|
||||
data Null a = Null
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Null where liftEq = genericLiftEq
|
||||
instance Ord1 Null where liftCompare = genericLiftCompare
|
||||
instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Null where eval _ _ _ = pure null
|
||||
|
||||
newtype Symbol a = Symbol { symbolElements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Symbol where liftEq = genericLiftEq
|
||||
instance Ord1 Symbol where liftCompare = genericLiftCompare
|
||||
instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Symbol
|
||||
instance Evaluatable Symbol
|
||||
|
||||
newtype SymbolElement a = SymbolElement { symbolContent :: Text }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 SymbolElement where liftEq = genericLiftEq
|
||||
instance Ord1 SymbolElement where liftCompare = genericLiftCompare
|
||||
instance Show1 SymbolElement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable SymbolElement where
|
||||
eval _ _ (SymbolElement s) = string s
|
||||
|
||||
newtype Regex a = Regex { regexContent :: Text }
|
||||
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
|
||||
|
||||
instance Eq1 Regex where liftEq = genericLiftEq
|
||||
instance Ord1 Regex where liftCompare = genericLiftCompare
|
||||
instance Show1 Regex where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Heredoc-style string literals?
|
||||
|
||||
-- TODO: Implement Eval instance for Regex
|
||||
instance Evaluatable Regex where
|
||||
eval _ _ (Regex x) = string x
|
||||
|
||||
-- Collections
|
||||
|
||||
newtype Array a = Array { arrayElements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Array where liftEq = genericLiftEq
|
||||
instance Ord1 Array where liftCompare = genericLiftCompare
|
||||
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Array where
|
||||
eval eval _ Array{..} = array =<< traverse eval arrayElements
|
||||
|
||||
newtype Hash a = Hash { hashElements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Hash where liftEq = genericLiftEq
|
||||
instance Ord1 Hash where liftCompare = genericLiftCompare
|
||||
instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Hash where
|
||||
eval eval _ t = do
|
||||
elements <- traverse (eval >=> asPair) (hashElements t)
|
||||
Eval.hash elements
|
||||
|
||||
data KeyValue a = KeyValue { key :: !a, value :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 KeyValue where liftEq = genericLiftEq
|
||||
instance Ord1 KeyValue where liftCompare = genericLiftCompare
|
||||
instance Show1 KeyValue where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable KeyValue where
|
||||
eval eval _ KeyValue{..} = do
|
||||
k <- eval key
|
||||
v <- eval value
|
||||
kvPair k v
|
||||
|
||||
newtype Tuple a = Tuple { tupleContents :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Tuple where liftEq = genericLiftEq
|
||||
instance Ord1 Tuple where liftCompare = genericLiftCompare
|
||||
instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Tuple where
|
||||
eval eval _ (Tuple cs) = tuple =<< traverse eval cs
|
||||
|
||||
newtype Set a = Set { setElements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Set where liftEq = genericLiftEq
|
||||
instance Ord1 Set where liftCompare = genericLiftCompare
|
||||
instance Show1 Set where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Set
|
||||
instance Evaluatable Set
|
||||
|
||||
|
||||
-- Pointers
|
||||
|
||||
-- | A declared pointer (e.g. var pointer *int in Go)
|
||||
newtype Pointer a = Pointer { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Pointer where liftEq = genericLiftEq
|
||||
instance Ord1 Pointer where liftCompare = genericLiftCompare
|
||||
instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Pointer
|
||||
instance Evaluatable Pointer
|
||||
|
||||
|
||||
-- | A reference to a pointer's address (e.g. &pointer in Go)
|
||||
newtype Reference a = Reference { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Reference where liftEq = genericLiftEq
|
||||
instance Ord1 Reference where liftCompare = genericLiftCompare
|
||||
instance Show1 Reference where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Reference
|
||||
instance Evaluatable Reference
|
||||
|
||||
-- TODO: Object literals as distinct from hash literals? Or coalesce object/hash literals into “key-value literals”?
|
||||
-- TODO: Function literals (lambdas, procs, anonymous functions, what have you).
|
||||
@ -1,408 +0,0 @@
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Data.Syntax.Statement (module Data.Syntax.Statement) where
|
||||
|
||||
import Control.Abstract hiding (Break, Catch, Continue, Return, Throw, While)
|
||||
import Data.Abstract.Evaluatable as Abstract hiding (Catch, Throw)
|
||||
import qualified Data.Abstract.ScopeGraph as ScopeGraph
|
||||
import Data.Aeson (ToJSON1 (..))
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import Data.List.NonEmpty (nonEmpty)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe.Exts
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
import GHC.Generics (Generic1)
|
||||
|
||||
-- | Imperative sequence of statements/declarations s.t.:
|
||||
--
|
||||
-- 1. Each statement’s effects on the store are accumulated;
|
||||
-- 2. Each statement can affect the environment of later statements (e.g. by 'modify'-ing the environment); and
|
||||
-- 3. Only the last statement’s return value is returned.
|
||||
-- TODO: Separate top-level statement nodes into non-lexical Statement and lexical StatementBlock nodes
|
||||
newtype Statements a = Statements { statements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
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
|
||||
eval eval _ (Statements xs) =
|
||||
maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs)
|
||||
|
||||
newtype StatementBlock a = StatementBlock { statements :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
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
|
||||
eval eval _ (StatementBlock xs) =
|
||||
maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs)
|
||||
|
||||
-- | 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, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 If where liftEq = genericLiftEq
|
||||
instance Ord1 If where liftCompare = genericLiftCompare
|
||||
instance Show1 If where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable If where
|
||||
eval eval _ (If cond if' else') = do
|
||||
bool <- eval cond
|
||||
ifthenelse bool (eval if') (eval else')
|
||||
|
||||
|
||||
-- | 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, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Else where liftEq = genericLiftEq
|
||||
instance Ord1 Else where liftCompare = genericLiftCompare
|
||||
instance Show1 Else where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Else
|
||||
instance Evaluatable Else
|
||||
|
||||
|
||||
-- TODO: Alternative definition would flatten if/else if/else chains: data If a = If ![(a, a)] !(Maybe a)
|
||||
|
||||
-- | Goto statement (e.g. `goto a` in Go).
|
||||
newtype Goto a = Goto { gotoLocation :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Goto where liftEq = genericLiftEq
|
||||
instance Ord1 Goto where liftCompare = genericLiftCompare
|
||||
instance Show1 Goto where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- 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, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Match where liftEq = genericLiftEq
|
||||
instance Ord1 Match where liftCompare = genericLiftCompare
|
||||
instance Show1 Match where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Match
|
||||
instance Evaluatable Match
|
||||
|
||||
|
||||
-- | 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, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Pattern where liftEq = genericLiftEq
|
||||
instance Ord1 Pattern where liftCompare = genericLiftCompare
|
||||
instance Show1 Pattern where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Pattern
|
||||
instance Evaluatable Pattern
|
||||
|
||||
-- | 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, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Let where liftEq = genericLiftEq
|
||||
instance Ord1 Let where liftCompare = genericLiftCompare
|
||||
instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Let where
|
||||
eval eval _ Let{..} = do
|
||||
-- This use of 'throwNoNameError' is okay until we have a better way of mapping gensym names to terms in the scope graph.
|
||||
valueName <- maybeM (throwNoNameError letValue) (declaredName letValue)
|
||||
assocScope <- associatedScope (Declaration valueName)
|
||||
|
||||
_ <- withLexicalScopeAndFrame $ do
|
||||
letSpan <- ask @Span
|
||||
name <- declareMaybeName (declaredName letVariable) Default Public letSpan ScopeGraph.Let assocScope
|
||||
letVal <- eval letValue
|
||||
slot <- lookupSlot (Declaration name)
|
||||
assign slot letVal
|
||||
eval letBody
|
||||
unit
|
||||
|
||||
|
||||
-- AugmentedAssignment
|
||||
|
||||
newtype AugmentedAssignment a = AugmentedAssignment { augmentedAssignmentTarget :: a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 AugmentedAssignment where liftEq = genericLiftEq
|
||||
instance Ord1 AugmentedAssignment where liftCompare = genericLiftCompare
|
||||
instance Show1 AugmentedAssignment where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations1 AugmentedAssignment where
|
||||
liftDeclaredName declaredName AugmentedAssignment{..} = declaredName augmentedAssignmentTarget
|
||||
|
||||
instance Evaluatable AugmentedAssignment
|
||||
|
||||
|
||||
-- Assignment
|
||||
|
||||
-- | Assignment to a variable or other lvalue.
|
||||
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
|
||||
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Assignment where liftEq = genericLiftEq
|
||||
instance Ord1 Assignment where liftCompare = genericLiftCompare
|
||||
instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Declarations1 Assignment where
|
||||
liftDeclaredName declaredName Assignment{..} = declaredName assignmentTarget
|
||||
|
||||
instance Evaluatable Assignment where
|
||||
eval eval ref Assignment{..} = do
|
||||
lhs <- ref assignmentTarget
|
||||
rhs <- eval assignmentValue
|
||||
|
||||
case declaredName assignmentValue of
|
||||
Just rhsName -> do
|
||||
assocScope <- associatedScope (Declaration rhsName)
|
||||
case assocScope of
|
||||
Just assocScope' -> do
|
||||
objectScope <- newScope (Map.singleton Import [ assocScope' ])
|
||||
putSlotDeclarationScope lhs (Just objectScope) -- TODO: not sure if this is right
|
||||
Nothing ->
|
||||
pure ()
|
||||
Nothing ->
|
||||
pure ()
|
||||
assign lhs rhs
|
||||
pure rhs
|
||||
|
||||
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
|
||||
newtype PostIncrement a = PostIncrement { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 PostIncrement where liftEq = genericLiftEq
|
||||
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
|
||||
instance Show1 PostIncrement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for PostIncrement
|
||||
instance Evaluatable PostIncrement
|
||||
|
||||
|
||||
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
|
||||
newtype PostDecrement a = PostDecrement { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 PostDecrement where liftEq = genericLiftEq
|
||||
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
|
||||
instance Show1 PostDecrement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for PostDecrement
|
||||
instance Evaluatable PostDecrement
|
||||
|
||||
-- | Pre increment operator (e.g. ++1 in C or Java).
|
||||
newtype PreIncrement a = PreIncrement { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 PreIncrement where liftEq = genericLiftEq
|
||||
instance Ord1 PreIncrement where liftCompare = genericLiftCompare
|
||||
instance Show1 PreIncrement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for PreIncrement
|
||||
instance Evaluatable PreIncrement
|
||||
|
||||
|
||||
-- | Pre decrement operator (e.g. --1 in C or Java).
|
||||
newtype PreDecrement a = PreDecrement { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 PreDecrement where liftEq = genericLiftEq
|
||||
instance Ord1 PreDecrement where liftCompare = genericLiftCompare
|
||||
instance Show1 PreDecrement where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for PreDecrement
|
||||
instance Evaluatable PreDecrement
|
||||
|
||||
|
||||
-- Returns
|
||||
|
||||
newtype Return a = Return { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Return where liftEq = genericLiftEq
|
||||
instance Ord1 Return where liftCompare = genericLiftCompare
|
||||
instance Show1 Return where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Return where
|
||||
eval eval _ (Return x) = eval x >>= earlyReturn
|
||||
|
||||
newtype Yield a = Yield { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Yield where liftEq = genericLiftEq
|
||||
instance Ord1 Yield where liftCompare = genericLiftCompare
|
||||
instance Show1 Yield where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Yield
|
||||
instance Evaluatable Yield
|
||||
|
||||
|
||||
newtype Break a = Break { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Break where liftEq = genericLiftEq
|
||||
instance Ord1 Break where liftCompare = genericLiftCompare
|
||||
instance Show1 Break where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Break where
|
||||
eval eval _ (Break x) = eval x >>= throwBreak
|
||||
|
||||
newtype Continue a = Continue { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Continue where liftEq = genericLiftEq
|
||||
instance Ord1 Continue where liftCompare = genericLiftCompare
|
||||
instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable Continue where
|
||||
eval eval _ (Continue x) = eval x >>= throwContinue
|
||||
|
||||
newtype Retry a = Retry { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Retry where liftEq = genericLiftEq
|
||||
instance Ord1 Retry where liftCompare = genericLiftCompare
|
||||
instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Retry
|
||||
instance Evaluatable Retry
|
||||
|
||||
newtype NoOp a = NoOp { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 NoOp where liftEq = genericLiftEq
|
||||
instance Ord1 NoOp where liftCompare = genericLiftCompare
|
||||
instance Show1 NoOp where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable NoOp where
|
||||
eval _ _ _ = unit
|
||||
|
||||
-- Loops
|
||||
|
||||
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 For where liftEq = genericLiftEq
|
||||
instance Ord1 For where liftCompare = genericLiftCompare
|
||||
instance Show1 For where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
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, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 ForEach where liftEq = genericLiftEq
|
||||
instance Ord1 ForEach where liftCompare = genericLiftCompare
|
||||
instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for ForEach
|
||||
instance Evaluatable ForEach
|
||||
|
||||
data While a = While { whileCondition :: !a, whileBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 While where liftEq = genericLiftEq
|
||||
instance Ord1 While where liftCompare = genericLiftCompare
|
||||
instance Show1 While where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable While where
|
||||
eval eval _ While{..} = while (eval whileCondition) (eval whileBody)
|
||||
|
||||
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 DoWhile where liftEq = genericLiftEq
|
||||
instance Ord1 DoWhile where liftCompare = genericLiftCompare
|
||||
instance Show1 DoWhile where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
instance Evaluatable DoWhile where
|
||||
eval eval _ DoWhile{..} = doWhile (eval doWhileBody) (eval doWhileCondition)
|
||||
|
||||
-- Exception handling
|
||||
|
||||
newtype Throw a = Throw { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Throw where liftEq = genericLiftEq
|
||||
instance Ord1 Throw where liftCompare = genericLiftCompare
|
||||
instance Show1 Throw where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Throw
|
||||
instance Evaluatable Throw
|
||||
|
||||
|
||||
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Try where liftEq = genericLiftEq
|
||||
instance Ord1 Try where liftCompare = genericLiftCompare
|
||||
instance Show1 Try where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Try
|
||||
instance Evaluatable Try
|
||||
|
||||
data Catch a = Catch { catchException :: !a, catchBody :: !a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Catch where liftEq = genericLiftEq
|
||||
instance Ord1 Catch where liftCompare = genericLiftCompare
|
||||
instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Catch
|
||||
instance Evaluatable Catch
|
||||
|
||||
newtype Finally a = Finally { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Finally where liftEq = genericLiftEq
|
||||
instance Ord1 Finally where liftCompare = genericLiftCompare
|
||||
instance Show1 Finally where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Finally
|
||||
instance Evaluatable Finally
|
||||
|
||||
-- Scoping
|
||||
|
||||
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
|
||||
newtype ScopeEntry a = ScopeEntry { terms :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 ScopeEntry where liftEq = genericLiftEq
|
||||
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
|
||||
instance Show1 ScopeEntry where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for ScopeEntry
|
||||
instance Evaluatable ScopeEntry
|
||||
|
||||
|
||||
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
|
||||
newtype ScopeExit a = ScopeExit { terms :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 ScopeExit where liftEq = genericLiftEq
|
||||
instance Ord1 ScopeExit where liftCompare = genericLiftCompare
|
||||
instance Show1 ScopeExit where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for ScopeExit
|
||||
instance Evaluatable ScopeExit
|
||||
@ -1,183 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Data.Syntax.Type (module Data.Syntax.Type) where
|
||||
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Functor.Classes.Generic
|
||||
import Data.Hashable.Lifted
|
||||
import GHC.Generics (Generic1)
|
||||
import Prelude hiding (Bool, Double, Float, Int)
|
||||
|
||||
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Array where liftEq = genericLiftEq
|
||||
instance Ord1 Array where liftCompare = genericLiftCompare
|
||||
instance Show1 Array where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Array
|
||||
instance Evaluatable Array
|
||||
|
||||
|
||||
-- TODO: What about type variables? re: FreeVariables1
|
||||
data Annotation a = Annotation { annotationSubject :: a, annotationType :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Annotation where liftEq = genericLiftEq
|
||||
instance Ord1 Annotation where liftCompare = genericLiftCompare
|
||||
instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Specialize Evaluatable for Type to unify the inferred type of the subject with the specified type
|
||||
instance Evaluatable Annotation where
|
||||
eval eval _ Annotation{..} = eval annotationSubject
|
||||
|
||||
|
||||
data Function a = Function { functionParameters :: [a], functionReturn :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Function where liftEq = genericLiftEq
|
||||
instance Ord1 Function where liftCompare = genericLiftCompare
|
||||
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Function
|
||||
instance Evaluatable Function
|
||||
|
||||
|
||||
newtype Interface a = Interface { values :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Interface where liftEq = genericLiftEq
|
||||
instance Ord1 Interface where liftCompare = genericLiftCompare
|
||||
instance Show1 Interface where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Interface
|
||||
instance Evaluatable Interface
|
||||
|
||||
data Map a = Map { mapKeyType :: a, mapElementType :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Map where liftEq = genericLiftEq
|
||||
instance Ord1 Map where liftCompare = genericLiftCompare
|
||||
instance Show1 Map where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Map
|
||||
instance Evaluatable Map
|
||||
|
||||
newtype Parenthesized a = Parenthesized { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Parenthesized where liftEq = genericLiftEq
|
||||
instance Ord1 Parenthesized where liftCompare = genericLiftCompare
|
||||
instance Show1 Parenthesized where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Parenthesized
|
||||
instance Evaluatable Parenthesized
|
||||
|
||||
newtype Pointer a = Pointer { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Pointer where liftEq = genericLiftEq
|
||||
instance Ord1 Pointer where liftCompare = genericLiftCompare
|
||||
instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Pointer
|
||||
instance Evaluatable Pointer
|
||||
|
||||
newtype Product a = Product { values :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Product where liftEq = genericLiftEq
|
||||
instance Ord1 Product where liftCompare = genericLiftCompare
|
||||
instance Show1 Product where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Product
|
||||
instance Evaluatable Product
|
||||
|
||||
|
||||
data Readonly a = Readonly
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Readonly where liftEq = genericLiftEq
|
||||
instance Ord1 Readonly where liftCompare = genericLiftCompare
|
||||
instance Show1 Readonly where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Readonly
|
||||
instance Evaluatable Readonly
|
||||
|
||||
newtype Slice a = Slice { value :: a }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Slice where liftEq = genericLiftEq
|
||||
instance Ord1 Slice where liftCompare = genericLiftCompare
|
||||
instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Slice
|
||||
instance Evaluatable Slice
|
||||
|
||||
newtype TypeParameters a = TypeParameters { terms :: [a] }
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 TypeParameters where liftEq = genericLiftEq
|
||||
instance Ord1 TypeParameters where liftCompare = genericLiftCompare
|
||||
instance Show1 TypeParameters where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for TypeParameters
|
||||
instance Evaluatable TypeParameters
|
||||
|
||||
-- data instead of newtype because no payload
|
||||
data Void a = Void
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Void where liftEq = genericLiftEq
|
||||
instance Ord1 Void where liftCompare = genericLiftCompare
|
||||
instance Show1 Void where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Void
|
||||
instance Evaluatable Void
|
||||
|
||||
-- data instead of newtype because no payload
|
||||
data Int a = Int
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Int where liftEq = genericLiftEq
|
||||
instance Ord1 Int where liftCompare = genericLiftCompare
|
||||
instance Show1 Int where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Int
|
||||
instance Evaluatable Int
|
||||
|
||||
data Float a = Float
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Float where liftEq = genericLiftEq
|
||||
instance Ord1 Float where liftCompare = genericLiftCompare
|
||||
instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Float
|
||||
instance Evaluatable Float
|
||||
|
||||
data Double a = Double
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Double where liftEq = genericLiftEq
|
||||
instance Ord1 Double where liftCompare = genericLiftCompare
|
||||
instance Show1 Double where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Double
|
||||
instance Evaluatable Double
|
||||
|
||||
data Bool a = Bool
|
||||
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
|
||||
|
||||
instance Eq1 Bool where liftEq = genericLiftEq
|
||||
instance Ord1 Bool where liftCompare = genericLiftCompare
|
||||
instance Show1 Bool where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- TODO: Implement Eval instance for Float
|
||||
instance Evaluatable Bool
|
||||
Loading…
Reference in New Issue
Block a user