diff --git a/app/Version.hs b/app/Version.hs new file mode 100644 --- /dev/null +++ b/app/Version.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +module Version (prettyVersion, version, compilationTimestamp) where + +prettyVersion :: String +prettyVersion = "Mulang Release " ++ version ++ ", compiled on " ++ compilationTimestamp + +version :: String +version = "4.0.0" + +compilationTimestamp :: String +compilationTimestamp = __DATE__ ++ " " ++ __TIME__ diff --git a/mulang.cabal b/mulang.cabal --- a/mulang.cabal +++ b/mulang.cabal @@ -1,5 +1,5 @@ name: mulang -version: 3.6.1 +version: 4.0.0 synopsis: An intermediate language designed to perform advanced code analysis description: Mulang is an intermediate language, a combinators library for static code analysis and a multilanguage comand line tool license: GPL @@ -40,8 +40,11 @@ Language.Mulang.Signature Language.Mulang.DomainLanguage Language.Mulang.Inspector + Language.Mulang.Inspector.Primitive Language.Mulang.Inspector.Generic + Language.Mulang.Inspector.Typed Language.Mulang.Inspector.ObjectOriented + Language.Mulang.Inspector.ObjectOriented.Polymorphism Language.Mulang.Inspector.Functional Language.Mulang.Inspector.Logic Language.Mulang.Inspector.Procedural @@ -53,6 +56,7 @@ Language.Mulang.Parsers.Prolog Language.Mulang.Parsers.Java Language.Mulang.Parsers.JavaScript + Language.Mulang.Parsers.Python Language.Mulang.Analyzer Language.Mulang.Analyzer.Analysis Language.Mulang.Analyzer.Analysis.Json @@ -74,8 +78,9 @@ haskell-src , language-java , language-javascript , + language-python , aeson , - inflections , + inflections <= 0.2.0.1, parsec , ParsecTools , split , @@ -101,6 +106,9 @@ build-tools: happy, alex + + other-modules: + Version ghc-options: -Wall diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -1,5 +1,10 @@ -module Data.List.Extra (headOrElse) where +module Data.List.Extra ( + headOrElse, + has) where -headOrElse:: a -> [a] -> a +headOrElse :: a -> [a] -> a headOrElse x [] = x headOrElse _ (x:_) = x + +has :: (a -> Bool) -> (b -> [a]) -> (b -> Bool) +has f g = any f . g diff --git a/src/Language/Mulang/Analyzer/Analysis.hs b/src/Language/Mulang/Analyzer/Analysis.hs --- a/src/Language/Mulang/Analyzer/Analysis.hs +++ b/src/Language/Mulang/Analyzer/Analysis.hs @@ -85,7 +85,8 @@ | Java | JavaScript | Prolog - | Haskell deriving (Show, Eq, Generic) + | Haskell + | Python deriving (Show, Eq, Generic) -- -- Analysis Output structures diff --git a/src/Language/Mulang/Analyzer/Analysis/Json.hs b/src/Language/Mulang/Analyzer/Analysis/Json.hs --- a/src/Language/Mulang/Analyzer/Analysis/Json.hs +++ b/src/Language/Mulang/Analyzer/Analysis/Json.hs @@ -23,7 +23,8 @@ instance FromJSON EquationBody instance FromJSON Expression instance FromJSON Pattern -instance FromJSON ComprehensionStatement +instance FromJSON Statement +instance FromJSON Type instance ToJSON AnalysisResult instance ToJSON ExpectationResult @@ -34,5 +35,6 @@ instance ToJSON EquationBody instance ToJSON Expression instance ToJSON Pattern -instance ToJSON ComprehensionStatement +instance ToJSON Statement +instance ToJSON Type diff --git a/src/Language/Mulang/Analyzer/ExpectationsCompiler.hs b/src/Language/Mulang/Analyzer/ExpectationsCompiler.hs --- a/src/Language/Mulang/Analyzer/ExpectationsCompiler.hs +++ b/src/Language/Mulang/Analyzer/ExpectationsCompiler.hs @@ -86,26 +86,42 @@ f "Instantiates" = binded instantiates f "Raises" = binded raises f "Rescues" = binded rescues + f "TypesParameterAs" = binded typesParameterAs + f "TypesAs" = binded typesAs + f "TypesReturnAs" = binded typesReturnAs f "Uses" = binded uses f "UsesAnonymousVariable" = simple usesAnonymousVariable f "UsesComposition" = simple usesComposition - f "UsesComprehension" = simple usesComprehension + f "UsesComprehension" = f "UsesForComprehension" f "UsesConditional" = simple usesConditional + f "UsesDyamicPolymorphism" = simple usesDyamicPolymorphism + f "UsesDynamicMethodOverload" = simple usesDynamicMethodOverload f "UsesExceptionHandling" = simple usesExceptionHandling f "UsesExceptions" = simple usesExceptions f "UsesFindall" = simple usesFindall + f "UsesFor" = simple usesFor f "UsesForall" = simple usesForall + f "UsesForComprehension" = simple usesForComprehension + f "UsesForeach" = simple usesForEach + f "UsesForLoop" = simple usesForLoop f "UsesGuards" = simple usesGuards f "UsesIf" = simple usesIf f "UsesInheritance" = simple usesInheritance f "UsesLambda" = simple usesLambda f "UsesMixins" = simple usesMixins f "UsesNot" = simple usesNot + f "UsesObjectComposition" = simple usesObjectComposition f "UsesPatternMatching" = simple usesPatternMatching f "UsesRepeat" = simple usesRepeat + f "UsesStaticMethodOverload" = simple usesStaticMethodOverload + f "UsesStaticPolymorphism" = simple usesStaticPolymorphism f "UsesSwitch" = simple usesSwitch + f "UsesTemplateMethod" = simple usesTemplateMethod + f "UsesType" = binded usesType f "UsesWhile" = simple usesWhile + f "UsesYield" = simple usesYield f _ = const Nothing simple i _ = Just i binded i b = Just $ i b + diff --git a/src/Language/Mulang/Analyzer/SampleParser.hs b/src/Language/Mulang/Analyzer/SampleParser.hs --- a/src/Language/Mulang/Analyzer/SampleParser.hs +++ b/src/Language/Mulang/Analyzer/SampleParser.hs @@ -7,6 +7,7 @@ import Language.Mulang.Parsers.JavaScript (parseJavaScript) import Language.Mulang.Parsers.Prolog (parseProlog) import Language.Mulang.Parsers.Java (parseJava) +import Language.Mulang.Parsers.Python (parsePython) import Language.Mulang.Analyzer.Analysis (Sample(..), Language(..)) parseSample :: Sample -> Either String Expression @@ -18,3 +19,4 @@ parserFor Java = parseJava parserFor JavaScript = maybeToEither parseJavaScript parserFor Prolog = parseProlog +parserFor Python = parsePython diff --git a/src/Language/Mulang/Analyzer/SmellsAnalyzer.hs b/src/Language/Mulang/Analyzer/SmellsAnalyzer.hs --- a/src/Language/Mulang/Analyzer/SmellsAnalyzer.hs +++ b/src/Language/Mulang/Analyzer/SmellsAnalyzer.hs @@ -22,10 +22,11 @@ allSmells = [ "DiscardsExceptions", "DoesConsolePrint", - "DoesNullTest", + "DoesNilTest", "DoesTypeTest", "HasAssignmentReturn", "HasCodeDuplication", + "HasEmptyIfBranches", "HasLongParameterList", "HasMisspelledIdentifiers", "HasRedundantBooleanComparison", @@ -40,7 +41,7 @@ "HasWrongCaseIdentifiers", "IsLongCode", "OverridesEqualOrHashButNotBoth", - "ReturnsNull", + "ReturnsNil", "UsesCut", "UsesFail", "UsesUnificationOperator" ] @@ -48,7 +49,7 @@ detectionFor :: Smell -> Detection detectionFor "DiscardsExceptions" = simple discardsExceptions detectionFor "DoesConsolePrint" = simple doesConsolePrint -detectionFor "DoesNullTest" = simple doesNullTest +detectionFor "DoesNilTest" = simple doesNilTest detectionFor "DoesTypeTest" = simple doesTypeTest detectionFor "HasAssignmentReturn" = simple hasAssignmentReturn detectionFor "HasCodeDuplication" = unsupported @@ -70,7 +71,7 @@ detectionFor "HasWrongCaseBinding" = withLanguage hasWrongCaseIdentifiers detectionFor "IsLongCode" = unsupported detectionFor "OverridesEqualOrHashButNotBoth" = simple overridesEqualOrHashButNotBoth -detectionFor "ReturnsNull" = simple returnsNull +detectionFor "ReturnsNil" = simple returnsNil detectionFor "UsesCut" = simple usesCut detectionFor "UsesFail" = simple usesFail detectionFor "UsesUnificationOperator" = simple usesUnificationOperator diff --git a/src/Language/Mulang/Ast.hs b/src/Language/Mulang/Ast.hs --- a/src/Language/Mulang/Ast.hs +++ b/src/Language/Mulang/Ast.hs @@ -12,19 +12,28 @@ -- | * logic programing -- | module Language.Mulang.Ast ( - equationParams, + subroutineBodyPatterns, + equationPatterns, Code, Equation(..), EquationBody(..), + Type(..), Expression(..), - ComprehensionStatement(..), + Statement(..), Pattern(..), Identifier, + SubroutineBody, + debug, + debugType, + debugPattern, pattern SimpleEquation, pattern SimpleFunction, pattern SimpleProcedure, pattern SimpleMethod, pattern SimpleSend, + pattern SubroutineSignature, + pattern VariableSignature, + pattern ModuleSignature, pattern MuTrue, pattern MuFalse, pattern Subroutine, @@ -42,11 +51,29 @@ data Equation = Equation [Pattern] EquationBody deriving (Eq, Show, Read, Generic) data EquationBody - = UnguardedBody Expression - | GuardedBody [(Expression, Expression)] - deriving (Eq, Show, Read, Generic) + = UnguardedBody Expression + | GuardedBody [(Expression, Expression)] + deriving (Eq, Show, Read, Generic) +type SubroutineBody = [Equation] +-- A Generic Type, that can be used for typing expressions, +-- classes, functions, variables and so on, using a @TypeSignature@ +-- or a @TypeCast@ +data Type + = SimpleType Identifier [Identifier] + -- ^ simple types, with a type identifier and type constraints + -- Useful for modelling variable types + | ParameterizedType [Identifier] Identifier [Identifier] + -- ^ parameterized types, with type inputs, type identifier and type constraints + -- Useful for modelling functions, methods and procedures types + | ConstrainedType [Identifier] + -- ^ constrained type, with just type constraints. + -- Usefull for modelling classes and interfaces types + | OtherType (Maybe String) (Maybe Type) + -- ^ unrecognized type, with optional code and nested type + deriving (Eq, Show, Read, Generic) + -- | Expression is the root element of a Mulang program. -- | With the exception of Patterns, nearly everything is an Expression: variable declarations, literals, -- | control structures, even object oriented classes declarations. @@ -54,25 +81,29 @@ -- | However, although all those elements can be used as subexpressions and have an dohave an associated value, -- | Mulang does not state WHICH is that value. data Expression - = TypeAlias Identifier + = TypeAlias Identifier Identifier -- ^ Functional programming type alias. -- Only the type alias identifier is parsed | Record Identifier -- ^ Imperative / Functional programming struct declaration. -- Only the record name is parsed - | TypeSignature Identifier [Identifier] Identifier + | TypeSignature Identifier Type -- ^ Generic type signature for a computation, - -- composed by a name, parameter types and return type + -- composed by a name and its type + | TypeCast Expression Type + -- ^ Generic type annotation for an expression. For example, + -- a Java cast: (String) anObject => TypeAnnotation (Variable "anObject") "String" + -- a Haskell inline type declaration: ... = x :: Int => TypeAnnotation (Variable "x") "Int" | EntryPoint Identifier Expression -- ^ Entry point with its body - | Function Identifier [Equation] + | Function Identifier SubroutineBody -- ^ Functional / Imperative programming function declaration. -- It is is composed by an identifier and one or more equations - | Procedure Identifier [Equation] + | Procedure Identifier SubroutineBody -- ^ Imperative programming procedure declaration. It is composed by a name and one or more equations - | Method Identifier [Equation] - | EqualMethod [Equation] - | HashMethod [Equation] + | Method Identifier SubroutineBody + | EqualMethod SubroutineBody + | HashMethod SubroutineBody | Variable Identifier Expression | Assignment Identifier Expression | Attribute Identifier Expression @@ -106,15 +137,16 @@ -- ^ Generic, non-curried application of a function or procedure, composed by the applied element itself, and the application arguments | Send Expression Expression [Expression] -- ^ Object oriented programming message send, composed by the reciever, selector and arguments - | New Identifier [Expression] + | New Expression [Expression] -- ^ Object oriented instantiation, composed by the class reference and instantiation arguments - | Implement Identifier + | Implement Expression -- ^ Object oriented instantiation, interface implementation - | Include Identifier + | Include Expression -- ^ Object oriented instantiation, mixin inclusion | Lambda [Pattern] Expression | If Expression Expression Expression | Return Expression + | Yield Expression | While Expression Expression -- ^ Imperative programming conditional repetition control structure, composed by a condition and a body | Repeat Expression Expression @@ -127,14 +159,17 @@ -- ^ Generic raise expression, like a throw or raise statament, composed by the raised expression | Print Expression -- ^ Generic print expression - | Comprehension Expression [ComprehensionStatement] + | For [Statement] Expression + | ForLoop Expression Expression Expression Expression + -- ^ Imperative / OOP programming c-style for loop | Sequence [Expression] -- ^ Generic sequence of statements - | Other + | Other (Maybe String) (Maybe Expression) + -- ^ Unrecognized expression, with optional description and body | Equal | NotEqual | Self - | MuNull + | None -- ^ Generic value indicating an absent expression, such as when there is no finally in a try or default in a switch or js' undefined | MuNil -- ^ Generic nothing value literal - nil, null or unit @@ -175,17 +210,28 @@ | WildcardPattern -- ^ wildcard pattern @_@ | UnionPattern [Pattern] - | OtherPattern - -- ^ Other unrecognized pattern + | OtherPattern (Maybe String) (Maybe Pattern) + -- ^ Other unrecognized pattern with optional code and nested pattern deriving (Eq, Show, Read, Generic) -data ComprehensionStatement - = MuGenerator Pattern Expression - | MuQualifier Expression - | LetStmt Expression +data Statement + = Generator Pattern Expression + | Guard Expression deriving (Eq, Show, Read, Generic) +debug :: Show a => a -> Expression +debug a = Other (Just (show a)) Nothing +debugType :: Show a => a -> Type +debugType a = OtherType (Just (show a)) Nothing + +debugPattern :: Show a => a -> Pattern +debugPattern a = OtherPattern (Just (show a)) Nothing + +pattern VariableSignature name t cs = TypeSignature name (SimpleType t cs) +pattern SubroutineSignature name args t cs = TypeSignature name (ParameterizedType args t cs) +pattern ModuleSignature name cs = TypeSignature name (ConstrainedType cs) + pattern SimpleEquation params body = Equation params (UnguardedBody body) pattern SimpleSend receptor selector args = Send receptor (Reference selector) args @@ -197,7 +243,7 @@ pattern MuTrue = MuBool True pattern MuFalse = MuBool False -pattern Subroutine name equations <- (extractSubroutine -> Just (name, equations)) +pattern Subroutine name body <- (extractSubroutine -> Just (name, body)) pattern Clause name patterns expressions <- (extractClause -> Just (name, patterns, expressions)) pattern Call operation arguments <- (extractCall -> Just (operation, arguments)) @@ -207,11 +253,17 @@ equationParams :: Equation -> [Pattern] equationParams (Equation p _) = p -extractSubroutine :: Expression -> Maybe (Identifier, [Equation]) -extractSubroutine (Function name equations) = Just (name, equations) -extractSubroutine (Procedure name equations) = Just (name, equations) -extractSubroutine (Method name equations) = Just (name, equations) -extractSubroutine _ = Nothing +subroutineBodyPatterns :: SubroutineBody -> [Pattern] +subroutineBodyPatterns = concatMap equationPatterns + +equationPatterns :: Equation -> [Pattern] +equationPatterns (Equation p _) = p + +extractSubroutine :: Expression -> Maybe (Identifier, SubroutineBody) +extractSubroutine (Function name body) = Just (name, body) +extractSubroutine (Procedure name body) = Just (name, body) +extractSubroutine (Method name body) = Just (name, body) +extractSubroutine _ = Nothing extractParams :: Expression -> Maybe ([Pattern]) extractParams (Subroutine _ equations) = Just (equationParams.head $ equations) diff --git a/src/Language/Mulang/Builder.hs b/src/Language/Mulang/Builder.hs --- a/src/Language/Mulang/Builder.hs +++ b/src/Language/Mulang/Builder.hs @@ -9,7 +9,7 @@ compactMap f = compact . map f compact :: [Expression] -> Expression -compact [] = MuNull +compact [] = None compact [e] = e compact es = Sequence es @@ -31,7 +31,8 @@ normalize (If e1 e2 e3) = If (normalize e1) (normalize e2) (normalize e3) normalize (While e1 e2) = While (normalize e1) (normalize e2) normalize (Match e1 equations) = Match (normalize e1) (map normalizeEquation equations) -normalize (Comprehension e1 stms) = Comprehension (normalize e1) stms +normalize (For stms e1) = For stms (normalize e1) +normalize (ForLoop init cond prog stmt) = ForLoop (normalize init) (normalize cond) (normalize prog) (normalize stmt) normalize (Return e) = Return (normalize e) normalize (Not e) = Not (normalize e) normalize (Forall e1 e2) = Forall (normalize e1) (normalize e2) diff --git a/src/Language/Mulang/Generator.hs b/src/Language/Mulang/Generator.hs --- a/src/Language/Mulang/Generator.hs +++ b/src/Language/Mulang/Generator.hs @@ -1,5 +1,6 @@ module Language.Mulang.Generator ( boundDeclarations, + declarators, declarations, declarationsOf, declaredIdentifiers, @@ -10,6 +11,7 @@ identifierReferences, transitiveReferencedIdentifiers, Generator, + Declarator, Expression(..)) where import Language.Mulang.Ast @@ -19,32 +21,36 @@ import Data.List (nub) type Generator a = Expression -> [a] +type Declarator = (Identifier, Expression) -- | Returns all the declarations their identifiers - -- | classes, methods, functions, records, local and global variables, and so on -- | -- | For example, in 'f x = g x where x = y', it returns '(f, f x = ...)' and '(x, x = y)' -declarations :: Generator (Identifier, Expression) -declarations (Sequence es) = concatMap declarations es -declarations e@(Attribute n _) = [(n, e)] -declarations e@(Class n _ b) = (n, e) : declarations b -declarations e@(Clause n _ es) = (n, e) : concatMap declarations es -declarations e@(Enumeration n _) = [(n, e)] -declarations e@(Interface n _ b) = (n, e) : declarations b -declarations e@(EntryPoint n b) = (n, e) : declarations b -declarations e@(Subroutine n b) = (n, e) : concatMap declarations (equationExpressions b) -declarations e@(Object n b) = (n, e) : declarations b -declarations e@(Clause n _ _) = [(n, e)] -declarations e@(Record n) = [(n, e)] -declarations e@(TypeAlias n) = [(n, e)] -declarations e@(TypeSignature n _ _)= [(n, e)] -declarations e@(Variable n _) = [(n, e)] -declarations _ = [] +declarators :: Generator Declarator +declarators (Sequence es) = concatMap declarators es +declarators e@(Attribute n _) = [(n, e)] +declarators e@(Class n _ b) = (n, e) : declarators b +declarators e@(Clause n _ es) = (n, e) : concatMap declarators es +declarators e@(Enumeration n _) = [(n, e)] +declarators e@(Interface n _ b) = (n, e) : declarators b +declarators e@(EntryPoint n b) = (n, e) : declarators b +declarators e@(Subroutine n b) = (n, e) : concatMap declarators (equationExpressions b) +declarators e@(Object n b) = (n, e) : declarators b +declarators e@(Clause n _ _) = [(n, e)] +declarators e@(Record n) = [(n, e)] +declarators e@(TypeAlias n _) = [(n, e)] +declarators e@(TypeSignature n _) = [(n, e)] +declarators e@(Variable n _) = [(n, e)] +declarators _ = [] +declarations :: Generator Expression +declarations = map snd . declarators + -- | Returns all declarations bound to the given identifier predicate -- | boundDeclarations :: IdentifierPredicate -> Generator Expression -boundDeclarations f = map snd . filter (f.fst) . declarations +boundDeclarations f = map snd . filter (f.fst) . declarators -- | Returns the given expression and all its subexpressions -- For example: in 'f x = x + 1', it returns 'f x = x + 1', 'x + 1', 'x' and '1' @@ -57,27 +63,33 @@ subExpressions (Call op args) = op:args subExpressions (Class _ _ v) = [v] subExpressions (Clause _ _ es) = es - subExpressions (Comprehension a _) = [a] --TODO subExpressions (EntryPoint _ e) = [e] + subExpressions (For stmts a) = statementExpressions stmts ++ [a] subExpressions (Forall e1 e2) = [e1, e2] + subExpressions (ForLoop i c p s) = [i, c, p, s] subExpressions (If a b c) = [a, b, c] + subExpressions (Implement e) = [e] + subExpressions (Include e) = [e] subExpressions (Interface _ _ v) = [v] subExpressions (Lambda _ a) = [a] subExpressions (Match e1 equations) = e1:equationExpressions equations subExpressions (MuList as) = as subExpressions (MuObject es) = [es] subExpressions (MuTuple as) = as - subExpressions (New _ es) = es + subExpressions (New e es) = e:es subExpressions (Not e) = [e] subExpressions (Object _ v) = [v] + subExpressions (Other _ (Just e)) = [e] subExpressions (Repeat e1 e2) = [e1, e2] subExpressions (Return v) = [v] subExpressions (Sequence es) = es subExpressions (Subroutine _ es) = equationExpressions es subExpressions (Switch e1 list _) = e1 : concatMap (\(x,y) -> [x,y]) list subExpressions (Try t cs f) = t : map snd cs ++ [f] + subExpressions (TypeCast e _) = [e] subExpressions (Variable _ v) = [v] subExpressions (While e1 e2) = [e1, e2] + subExpressions (Yield v) = [v] subExpressions _ = [] @@ -106,7 +118,7 @@ -- | Returns all the declared identifiers -- For example, in 'f x = g x where x = y', it returns 'f' and 'x' declaredIdentifiers :: Generator Identifier -declaredIdentifiers = map fst . declarations +declaredIdentifiers = map fst . declarators mainDeclaredIdentifiers :: Generator Identifier mainDeclaredIdentifiers (Sequence _) = [] @@ -114,7 +126,7 @@ -- | Returns all the body equations of functions, procedures and methods equationBodies :: Generator EquationBody -equationBodies = concatMap (bodiesOf . snd) . declarations +equationBodies = concatMap bodiesOf . declarations where bodiesOf :: Generator EquationBody bodiesOf (Subroutine _ equations) = equationBodies equations @@ -128,12 +140,14 @@ extractReference :: Expression -> Maybe Identifier extractReference (Reference n) = Just n extractReference (Exist n _) = Just n -extractReference (New n _) = Just n -extractReference (Implement n) = Just n -extractReference (Include n) = Just n extractReference _ = Nothing equationExpressions = concatMap (\(Equation _ body) -> bodyExpressions body) where bodyExpressions (UnguardedBody e) = [e] bodyExpressions (GuardedBody b) = b >>= \(es1, es2) -> [es1, es2] + +statementExpressions = map expression + where + expression (Generator _ e) = e + expression (Guard e) = e diff --git a/src/Language/Mulang/Inspector.hs b/src/Language/Mulang/Inspector.hs --- a/src/Language/Mulang/Inspector.hs +++ b/src/Language/Mulang/Inspector.hs @@ -1,15 +1,21 @@ module Language.Mulang.Inspector ( + Inspection, + IdentifierInspection, module Language.Mulang.Inspector.Generic, module Language.Mulang.Inspector.Combiner, + module Language.Mulang.Inspector.Typed, module Language.Mulang.Inspector.ObjectOriented, + module Language.Mulang.Inspector.ObjectOriented.Polymorphism, module Language.Mulang.Inspector.Functional, module Language.Mulang.Inspector.Logic, module Language.Mulang.Inspector.Procedural) where - +import Language.Mulang.Inspector.Primitive (Inspection, IdentifierInspection) import Language.Mulang.Inspector.Generic +import Language.Mulang.Inspector.Typed import Language.Mulang.Inspector.Combiner import Language.Mulang.Inspector.ObjectOriented +import Language.Mulang.Inspector.ObjectOriented.Polymorphism import Language.Mulang.Inspector.Functional import Language.Mulang.Inspector.Logic import Language.Mulang.Inspector.Procedural diff --git a/src/Language/Mulang/Inspector/Combiner.hs b/src/Language/Mulang/Inspector/Combiner.hs --- a/src/Language/Mulang/Inspector/Combiner.hs +++ b/src/Language/Mulang/Inspector/Combiner.hs @@ -9,7 +9,7 @@ import Language.Mulang.Ast import Language.Mulang.Generator (transitiveReferencedIdentifiers, declarationsOf, declaredIdentifiers) -import Language.Mulang.Inspector.Generic +import Language.Mulang.Inspector.Primitive detect :: Inspection -> Expression -> [Identifier] detect i expression = diff --git a/src/Language/Mulang/Inspector/Functional.hs b/src/Language/Mulang/Inspector/Functional.hs --- a/src/Language/Mulang/Inspector/Functional.hs +++ b/src/Language/Mulang/Inspector/Functional.hs @@ -3,12 +3,14 @@ usesComposition, usesLambda, usesPatternMatching, + usesForComprehension, usesComprehension, usesConditional) where import Language.Mulang.Ast -import Language.Mulang.Inspector.Generic -import Language.Mulang.Inspector.Combiner +import Language.Mulang.Inspector.Primitive (Inspection, containsExpression, containsBody) +import Language.Mulang.Inspector.Generic (usesIf, usesYield) +import Language.Mulang.Inspector.Combiner (alternative) usesConditional :: Inspection usesConditional = alternative usesIf usesGuards @@ -38,10 +40,14 @@ -- | Inspection that tells whether an expression uses -- comprehensions - list comprehension, for comprehension, do-syntax, etc - -- in its definitions +usesForComprehension :: Inspection +usesForComprehension = containsExpression f + where f (For _ e) = usesYield e + f _ = False + +-- alias for usesForComprehension inspection usesComprehension :: Inspection -usesComprehension = containsExpression f - where f (Comprehension _ _) = True - f _ = False +usesComprehension = usesForComprehension -- | Inspection that tells whether an expression uses a lambda expression -- in its definition diff --git a/src/Language/Mulang/Inspector/Generic.hs b/src/Language/Mulang/Inspector/Generic.hs --- a/src/Language/Mulang/Inspector/Generic.hs +++ b/src/Language/Mulang/Inspector/Generic.hs @@ -4,6 +4,8 @@ calls, uses, usesIf, + usesYield, + usesFor, declares, declaresVariable, declaresRecursively, @@ -12,29 +14,20 @@ declaresComputation, declaresComputationWithArity, declaresComputationWithArity', - declaresTypeAlias, - declaresTypeSignature, usesAnonymousVariable, raises, rescues, usesExceptions, - usesExceptionHandling, - containsExpression, - containsDeclaration, - containsBoundDeclaration, - containsBody, - matchesType, - Inspection, - IdentifierInspection) where + usesExceptionHandling) where import Language.Mulang.Ast import Language.Mulang.Identifier -import Language.Mulang.Generator (expressions, boundDeclarations, equationBodies, declarations, referencedIdentifiers) +import Language.Mulang.Inspector.Primitive +import Language.Mulang.Generator (declaredIdentifiers, referencedIdentifiers) import Data.Maybe (listToMaybe) +import Data.List.Extra (has) -type Inspection = Expression -> Bool -type IdentifierInspection = IdentifierPredicate -> Inspection -- | Inspection that tells whether an expression is equal to a given piece of code after being parsed parses :: (String -> Expression) -> String -> Inspection @@ -66,11 +59,22 @@ where f (If _ _ _) = True f _ = False +usesYield :: Inspection +usesYield = containsExpression f + where f (Yield _) = True + f _ = False + +usesFor :: Inspection +usesFor = containsExpression f + where f (For _ _) = True + f _ = False + + -- | Inspection that tells whether a top level declaration exists declares :: IdentifierInspection declares = containsBoundDeclaration f - where f (TypeSignature _ _ _) = False - f _ = True + where f (TypeSignature _ _) = False + f _ = True -- | Inspection that tells whether an expression is direct recursive declaresRecursively :: IdentifierInspection @@ -79,7 +83,7 @@ | otherwise = False nameOf :: Expression -> Maybe Identifier - nameOf = fmap fst . listToMaybe . declarations + nameOf = listToMaybe . declaredIdentifiers declaresFunction :: IdentifierInspection @@ -114,21 +118,11 @@ argsHaveArity = arityPredicate.length -declaresTypeAlias :: IdentifierInspection -declaresTypeAlias = containsBoundDeclaration f - where f (TypeAlias _) = True - f _ = False - -declaresTypeSignature :: IdentifierInspection -declaresTypeSignature = containsBoundDeclaration f - where f (TypeSignature _ _ _) = True - f _ = False - raises :: IdentifierInspection raises predicate = containsExpression f - where f (Raise (New n _)) = predicate n - f (Raise (Reference n)) = predicate n - f _ = False + where f (Raise (New (Reference n) _)) = predicate n + f (Raise (Reference n)) = predicate n + f _ = False usesExceptions :: Inspection usesExceptions = containsExpression f @@ -147,13 +141,12 @@ usesAnonymousVariable :: Inspection usesAnonymousVariable = containsExpression f - where f (Subroutine _ equations) = equationContainsWildcard equations ---TODO f (Lambda args _) = equationContainsWildcard equations - f (Clause _ params _) = paramsContainsWildcard params - f _ = False + where f (Subroutine _ body) = equationContainsWildcard body +--TODO f (Lambda args _) = equationContainsWildcard equations + f (Clause _ params _) = any isOrContainsWildcard params + f _ = False - equationContainsWildcard = any (paramsContainsWildcard . equationParams) - paramsContainsWildcard = any isOrContainsWildcard + equationContainsWildcard = has isOrContainsWildcard subroutineBodyPatterns isOrContainsWildcard (InfixApplicationPattern p1 _ p2) = any isOrContainsWildcard [p1, p2] isOrContainsWildcard (ApplicationPattern _ ps) = any isOrContainsWildcard ps @@ -163,29 +156,3 @@ isOrContainsWildcard (AsPattern _ p) = isOrContainsWildcard p isOrContainsWildcard WildcardPattern = True isOrContainsWildcard _ = False - - -containsExpression :: (Expression -> Bool) -> Inspection -containsExpression f = has f expressions - -containsBody :: (EquationBody -> Bool)-> Inspection -containsBody f = has f equationBodies - -containsBoundDeclaration :: (Expression -> Bool) -> IdentifierInspection -containsBoundDeclaration f b = has f (boundDeclarations b) - -containsDeclaration :: (Expression -> Bool) -> Inspection -containsDeclaration f = has f (map snd . declarations) - -matchesType :: IdentifierPredicate -> Pattern -> Bool -matchesType predicate (TypePattern n) = predicate n -matchesType predicate (AsPattern _ (TypePattern n)) = predicate n -matchesType predicate (UnionPattern patterns) = any (matchesType predicate) patterns -matchesType _ _ = False - --- private - -has f g = any f . g - - - diff --git a/src/Language/Mulang/Inspector/Generic/Duplication.hs b/src/Language/Mulang/Inspector/Generic/Duplication.hs --- a/src/Language/Mulang/Inspector/Generic/Duplication.hs +++ b/src/Language/Mulang/Inspector/Generic/Duplication.hs @@ -1,7 +1,7 @@ module Language.Mulang.Inspector.Generic.Duplication (hasCodeDuplication) where import Language.Mulang.Ast -import Language.Mulang.Inspector +import Language.Mulang.Inspector.Primitive import Language.Mulang.Generator (expressions) import qualified Data.Hashable as H (hash) import Data.List (nub, subsequences) @@ -15,7 +15,7 @@ isLightweight (MuBool _) = True isLightweight (Reference _) = True isLightweight Self = True -isLightweight MuNull = True +isLightweight None = True isLightweight MuNil = True isLightweight Equal = True isLightweight (Application _ es) = not $ any isApplication es diff --git a/src/Language/Mulang/Inspector/Generic/Smell.hs b/src/Language/Mulang/Inspector/Generic/Smell.hs --- a/src/Language/Mulang/Inspector/Generic/Smell.hs +++ b/src/Language/Mulang/Inspector/Generic/Smell.hs @@ -7,10 +7,10 @@ hasRedundantLocalVariableReturn, hasAssignmentReturn, hasEmptyIfBranches, - doesNullTest, + doesNilTest, doesTypeTest, isLongCode, - returnsNull, + returnsNil, discardsExceptions, doesConsolePrint, hasLongParameterList, @@ -18,15 +18,15 @@ overridesEqualOrHashButNotBoth) where import Language.Mulang.Ast -import Language.Mulang.Inspector -import Language.Mulang.Generator(identifierReferences) +import Language.Mulang.Generator (identifierReferences) +import Language.Mulang.Inspector.Primitive -- | Inspection that tells whether an identifier has expressions like 'x == True' hasRedundantBooleanComparison :: Inspection hasRedundantBooleanComparison = compares isBooleanLiteral -doesNullTest :: Inspection -doesNullTest = compares f +doesNilTest :: Inspection +doesNilTest = compares f where f MuNil = True f _ = False @@ -47,8 +47,8 @@ comparisonOperands (Call NotEqual [a1, a2]) = [a1, a2] comparisonOperands _ = [] -returnsNull :: Inspection -returnsNull = containsExpression f +returnsNil :: Inspection +returnsNil = containsExpression f where f (Return MuNil) = True f _ = False @@ -59,6 +59,7 @@ where f (If _ (Assignment v1 x) (Assignment v2 y)) = all isBooleanLiteral [x, y] && v1 == v2 f (If _ (Variable v1 x) (Variable v2 y)) = all isBooleanLiteral [x, y] && v1 == v2 f (If _ (Return x) (Return y)) = all isBooleanLiteral [x, y] + f (If _ (Yield x) (Yield y)) = all isBooleanLiteral [x, y] f (If _ x y) = all isBooleanLiteral [x, y] f _ = False @@ -83,11 +84,13 @@ -- can be avoided using point-free hasRedundantParameter :: Inspection hasRedundantParameter = containsExpression f - where f function@(SimpleFunction _ params (Return (Application _ args))) | (VariablePattern param) <- last params, - (Reference arg) <- last args = param == arg && showsUpOnlyOnce param (identifierReferences function) + where f function@(SimpleFunction _ params (Return (Application _ args))) | Just (VariablePattern param) <- safeLast params, + Just (Reference arg) <- safeLast args = param == arg && showsUpOnlyOnce param (identifierReferences function) f _ = False showsUpOnlyOnce p = (==1).countElem p countElem p = length.filter (==p) + safeLast [] = Nothing + safeLast l = Just $ last l isBooleanLiteral (MuBool _) = True isBooleanLiteral _ = False @@ -106,7 +109,7 @@ discardsExceptions :: Inspection discardsExceptions = containsExpression f - where f (Try _ [(_, MuNull)] _) = True + where f (Try _ [(_, None)] _) = True f (Try _ [(_, Print _)] _) = True f _ = False @@ -125,7 +128,7 @@ hasTooManyMethods = containsExpression f where f (Sequence expressions) = (>15).length.filter isMethod $ expressions f _ = False - + isMethod (Method _ _) = True isMethod _ = False @@ -138,11 +141,11 @@ isEqual (EqualMethod _) = True isEqual _ = False - + isHash (HashMethod _) = True isHash _ = False hasEmptyIfBranches :: Inspection hasEmptyIfBranches = containsExpression f - where f (If _ MuNull elseBranch) = elseBranch /= MuNull + where f (If _ None elseBranch) = elseBranch /= None f _ = False diff --git a/src/Language/Mulang/Inspector/Logic.hs b/src/Language/Mulang/Inspector/Logic.hs --- a/src/Language/Mulang/Inspector/Logic.hs +++ b/src/Language/Mulang/Inspector/Logic.hs @@ -12,15 +12,16 @@ import Language.Mulang.Ast import Language.Mulang.Identifier -import Language.Mulang.Inspector.Generic -import Language.Mulang.Inspector.Combiner +import Language.Mulang.Inspector.Primitive (Inspection, IdentifierInspection, containsExpression, containsBoundDeclaration) +import Language.Mulang.Inspector.Generic (uses) +import Language.Mulang.Inspector.Combiner (alternative) -declaresFact :: IdentifierPredicate -> Inspection +declaresFact :: IdentifierInspection declaresFact = containsBoundDeclaration f where f (Fact _ _) = True f _ = False -declaresRule :: IdentifierPredicate -> Inspection +declaresRule :: IdentifierInspection declaresRule = containsBoundDeclaration f where f (Rule _ _ _) = True f _ = False @@ -55,5 +56,5 @@ f (Exist "is" [(VariablePattern _), _]) = True f _ = False -declaresPredicate :: IdentifierPredicate -> Inspection +declaresPredicate :: IdentifierInspection declaresPredicate pred = alternative (declaresFact pred) (declaresRule pred) diff --git a/src/Language/Mulang/Inspector/ObjectOriented.hs b/src/Language/Mulang/Inspector/ObjectOriented.hs --- a/src/Language/Mulang/Inspector/ObjectOriented.hs +++ b/src/Language/Mulang/Inspector/ObjectOriented.hs @@ -15,17 +15,19 @@ import Language.Mulang.Ast import Language.Mulang.Identifier -import Language.Mulang.Inspector.Generic +import Language.Mulang.Inspector.Primitive ( + Inspection, IdentifierInspection, + containsExpression, containsDeclaration, containsBoundDeclaration) implements :: IdentifierInspection implements predicate = containsExpression f - where f (Implement name) = predicate name - f _ = False + where f (Implement (Reference name)) = predicate name + f _ = False includes :: IdentifierInspection includes predicate = containsExpression f - where f (Include name) = predicate name - f _ = False + where f (Include (Reference name)) = predicate name + f _ = False inherits :: IdentifierInspection inherits predicate = containsDeclaration f @@ -34,8 +36,8 @@ instantiates :: IdentifierInspection instantiates predicate = containsExpression f - where f (New name _) = predicate name - f _ = False + where f (New (Reference name) _) = predicate name + f _ = False usesInheritance :: Inspection usesInheritance = declaresSuperclass anyone @@ -75,3 +77,4 @@ declaresMethod = containsBoundDeclaration f where f (Method _ _) = True f _ = False + diff --git a/src/Language/Mulang/Inspector/ObjectOriented/Polymorphism.hs b/src/Language/Mulang/Inspector/ObjectOriented/Polymorphism.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Inspector/ObjectOriented/Polymorphism.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE ViewPatterns #-} + +module Language.Mulang.Inspector.ObjectOriented.Polymorphism ( + usesDyamicPolymorphism, + usesStaticPolymorphism, + usesTemplateMethod, + usesObjectComposition, + usesDynamicMethodOverload, + usesStaticMethodOverload) where + +import Language.Mulang.Ast +import Language.Mulang.Identifier +import Language.Mulang.Inspector.Primitive (Inspection) +import Language.Mulang.Inspector.ObjectOriented (implements, declaresMethod) +import Language.Mulang.Inspector.Typed (usesType) + +import Control.Monad (MonadPlus, guard) +import Language.Mulang.Generator (Generator, declarations, expressions) + +usesDynamicMethodOverload :: Inspection +usesDynamicMethodOverload expression = inspect $ do + klass@(Class _ _ _) <- declarations expression + (SimpleMethod n1 (length -> a1) _) <- declarations klass + (SimpleMethod n2 (length -> a2) _) <- declarations klass + guard (n1 == n2 && a1 /= a2) + +usesStaticMethodOverload :: Inspection +usesStaticMethodOverload expression = inspect $ do + klass@(Class _ _ _) <- declarations expression + s1@(SubroutineSignature n1 _ _ _) <- declarations klass + s2@(SubroutineSignature n2 _ _ _) <- declarations klass + guard (n1 == n2 && s1 /= s2) + +usesObjectComposition :: Inspection +usesObjectComposition expression = inspect $ do + klass@(Class _ _ _) <- declarations expression + (Attribute name1 _) <- declarations klass + (Send (Reference name2) _ _) <- expressions klass + guard (name1 == name2) + +usesTemplateMethod :: Inspection +usesTemplateMethod expression = inspect $ do + klass@(Class _ _ _) <- declarations expression + (SimpleSend Self selector _) <- expressions klass + guard (not . declaresMethod (named selector) $ klass) + +usesDyamicPolymorphism :: Inspection +usesDyamicPolymorphism expression = inspect $ do + (SimpleSend _ selector _) <- expressions expression + guardCount (>1) (methodDeclarationsOf selector expression) + +usesStaticPolymorphism :: Inspection +usesStaticPolymorphism expression = inspect $ do + interface@(Interface interfaceId _ _) <- declarations expression + (SubroutineSignature _ _ _ _) <- declarations interface + guard (usesType (named interfaceId) expression) + guardCount (>1) (implementorsOf interfaceId expression) + +-- private + +inspect :: [a] -> Bool +inspect = not.null + +guardCount :: MonadPlus m => (Int -> Bool) -> [a] -> m () +guardCount condition list = guard (condition . length $ list) + +methodDeclarationsOf :: Identifier -> Generator Expression +methodDeclarationsOf selector e = do + m@(Method s _) <- declarations e + guard (s == selector) + return m + +implementorsOf :: Identifier -> Generator Expression +implementorsOf id e = do + m@(Class _ _ _) <- declarations e + guard (implements (named id) m) + return m diff --git a/src/Language/Mulang/Inspector/Primitive.hs b/src/Language/Mulang/Inspector/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Inspector/Primitive.hs @@ -0,0 +1,36 @@ +module Language.Mulang.Inspector.Primitive ( + containsExpression, + containsDeclaration, + containsBoundDeclaration, + containsBody, + matchesType, + Inspection, + IdentifierInspection) where + +import Language.Mulang.Ast +import Language.Mulang.Identifier (IdentifierPredicate) +import Language.Mulang.Generator (expressions, boundDeclarations, equationBodies, declarations) + +import Data.List.Extra (has) + +type Inspection = Expression -> Bool +type IdentifierInspection = IdentifierPredicate -> Inspection + +containsExpression :: (Expression -> Bool) -> Inspection +containsExpression f = has f expressions + +containsBody :: (EquationBody -> Bool)-> Inspection +containsBody f = has f equationBodies + +containsBoundDeclaration :: (Expression -> Bool) -> IdentifierInspection +containsBoundDeclaration f b = has f (boundDeclarations b) + +containsDeclaration :: (Expression -> Bool) -> Inspection +containsDeclaration f = has f declarations + +matchesType :: IdentifierPredicate -> Pattern -> Bool +matchesType predicate (TypePattern n) = predicate n +matchesType predicate (AsPattern _ (TypePattern n)) = predicate n +matchesType predicate (UnionPattern patterns) = any (matchesType predicate) patterns +matchesType _ _ = False + diff --git a/src/Language/Mulang/Inspector/Procedural.hs b/src/Language/Mulang/Inspector/Procedural.hs --- a/src/Language/Mulang/Inspector/Procedural.hs +++ b/src/Language/Mulang/Inspector/Procedural.hs @@ -2,13 +2,15 @@ usesRepeat, usesWhile, usesSwitch, + usesForEach, + usesForLoop, declaresProcedure) where import Language.Mulang.Ast -import Language.Mulang.Identifier -import Language.Mulang.Inspector.Generic +import Language.Mulang.Inspector.Primitive (Inspection, IdentifierInspection, containsExpression, containsBoundDeclaration) +import Language.Mulang.Inspector.Generic (usesYield) -declaresProcedure :: IdentifierPredicate -> Inspection +declaresProcedure :: IdentifierInspection declaresProcedure = containsBoundDeclaration f where f (Procedure _ _) = True f _ = False @@ -34,3 +36,12 @@ where f (Repeat _ _) = True f _ = False +usesForEach :: Inspection +usesForEach = containsExpression f + where f (For _ e) = not $ usesYield e + f _ = False + +usesForLoop :: Inspection +usesForLoop = containsExpression f + where f (ForLoop _ _ _ _) = True + f _ = False diff --git a/src/Language/Mulang/Inspector/Typed.hs b/src/Language/Mulang/Inspector/Typed.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Inspector/Typed.hs @@ -0,0 +1,41 @@ +module Language.Mulang.Inspector.Typed ( + declaresTypeAlias, + declaresTypeSignature, + typesAs, + typesParameterAs, + typesReturnAs, + usesType) where + +import Language.Mulang.Ast +import Language.Mulang.Inspector.Primitive (IdentifierInspection, containsDeclaration, containsBoundDeclaration) + +declaresTypeAlias :: IdentifierInspection +declaresTypeAlias = containsBoundDeclaration f + where f (TypeAlias _ _) = True + f _ = False + +typesReturnAs :: IdentifierInspection +typesReturnAs predicate = containsDeclaration f + where f (SubroutineSignature _ _ name _) = predicate name + f _ = False + +typesParameterAs :: IdentifierInspection +typesParameterAs predicate = containsDeclaration f + where f (SubroutineSignature _ names _ _) = any predicate names + f _ = False + +typesAs :: IdentifierInspection +typesAs predicate = containsDeclaration f + where f (VariableSignature _ name _) = predicate name + f _ = False + +usesType :: IdentifierInspection +usesType predicate = containsDeclaration f + where f (VariableSignature _ name _) = predicate name + f (SubroutineSignature _ args ret _) = any predicate (ret:args) + f _ = False + +declaresTypeSignature :: IdentifierInspection +declaresTypeSignature = containsBoundDeclaration f + where f (TypeSignature _ _) = True + f _ = False diff --git a/src/Language/Mulang/Parsers/Haskell.hs b/src/Language/Mulang/Parsers/Haskell.hs --- a/src/Language/Mulang/Parsers/Haskell.hs +++ b/src/Language/Mulang/Parsers/Haskell.hs @@ -29,9 +29,10 @@ where mergeDecls decls exp = compact (decls ++ [exp]) - muDecls (HsTypeDecl _ name _ _) = [TypeAlias (muName name)] + muDecls (HsTypeDecl _ name args t) = [TypeAlias (unwords . map muName $ name : args) (muTypeId t)] muDecls (HsDataDecl _ _ name _ _ _ ) = [Record (muName name)] - muDecls (HsTypeSig _ names (HsQualType _ t)) = map (muTypeSignature t) names + muDecls (HsTypeSig _ names (HsQualType constraints t)) + = map (muTypeSignature constraints t) names muDecls (HsFunBind equations) | (HsMatch _ name _ _ _) <- head equations = [Function (muName name) (map muEquation equations)] muDecls (HsPatBind _ (HsPVar name) (HsUnGuardedRhs exp) _) = [Variable (muName name) (muExp exp)] @@ -57,7 +58,7 @@ muPat (HsPParen pattern) = muPat pattern muPat (HsPAsPat name pattern) = AsPattern (muName name) (muPat pattern) muPat HsPWildCard = WildcardPattern - muPat _ = OtherPattern + muPat p = debugPattern p muExp (HsVar (UnQual (HsIdent "undefined"))) = Raise (MuString "undefined") @@ -87,9 +88,10 @@ muExp (HsEnumFromTo from to) = Application (Reference "enumFromTo") [(muExp from), (muExp to)] muExp (HsEnumFromThen from thn) = Application (Reference "enumFromThen") [(muExp from), (muExp thn)] muExp (HsEnumFromThenTo from thn to) = Application (Reference "enumFromThenTo") [(muExp from), (muExp thn), (muExp to)] - muExp (HsListComp exp stmts) = Comprehension (muExp exp) (map muStmt stmts) - muExp (HsDo stmts) | (HsQualifier exp) <- last stmts = Comprehension (muExp exp) (map muStmt stmts) - muExp _ = Other + muExp (HsListComp exp stmts) = For (map muStmt stmts) (Yield (muExp exp)) + muExp (HsDo stmts) | (HsQualifier exp) <- last stmts = For (map muStmt stmts) (Yield (muExp exp)) + muExp (HsExpTypeSig _ exp (HsQualType cs t)) = TypeCast (muExp exp) (muType t cs) + muExp e = debug e muLit (HsCharPrim v) = MuString [v] muLit (HsStringPrim v) = MuString v @@ -121,19 +123,33 @@ muQOp (HsQVarOp name) = muQName name muQOp (HsQConOp name) = muQName name - muStmt (HsGenerator _ pat exp) = MuGenerator (muPat pat) (muExp exp) - muStmt (HsQualifier exp) = MuQualifier (muExp exp) + muStmt (HsGenerator _ pat exp) = Generator (muPat pat) (muExp exp) + muStmt (HsQualifier exp) = Guard (muExp exp) - muTypeSignature t name = TypeSignature (muName name) (init topTypes) (last topTypes) - where topTypes = muTopTypes t + muTypeSignature :: [HsAsst] -> HsType -> HsName -> Expression + muTypeSignature cs t name = TypeSignature (muName name) (muType t cs) - muTopTypes (HsTyFun i o) = muType i : muTopTypes o - muTopTypes t = [muType t] + muType :: HsType -> [HsAsst] -> Type + muType t cs | null initTypes = SimpleType lastType constraints + | otherwise = ParameterizedType initTypes lastType constraints + where + initTypes = init topTypes + lastType = last topTypes + topTypes = muTopTypes t + constraints = map muConstraint cs - muType (HsTyFun i o) = muType i ++ " -> " ++ muType o - muType (HsTyCon name) = muQName name - muType (HsTyVar name) = muName name - muType (HsTyTuple ts) = "(" ++ (intercalate ", " . map muType $ ts) ++ ")" - muType (HsTyApp (HsTyCon (Special HsListCon)) t2) = "[" ++ muType t2 ++ "]" - muType (HsTyApp t1 t2) = muType t1 ++ " " ++ muType t2 + muConstraint :: HsAsst -> Identifier + muConstraint (constraint, targets) = + intercalate " " (muQName constraint : map muTypeId targets) + + muTopTypes (HsTyFun i o) = muTypeId i : muTopTypes o + muTopTypes t = [muTypeId t] + + muTypeId :: HsType -> Identifier + muTypeId (HsTyFun i o) = muTypeId i ++ " -> " ++ muTypeId o + muTypeId (HsTyCon name) = muQName name + muTypeId (HsTyVar name) = muName name + muTypeId (HsTyTuple ts) = "(" ++ (intercalate ", " . map muTypeId $ ts) ++ ")" + muTypeId (HsTyApp (HsTyCon (Special HsListCon)) t2) = "[" ++ muTypeId t2 ++ "]" + muTypeId (HsTyApp t1 t2) = muTypeId t1 ++ " " ++ muTypeId t2 diff --git a/src/Language/Mulang/Parsers/Java.hs b/src/Language/Mulang/Parsers/Java.hs --- a/src/Language/Mulang/Parsers/Java.hs +++ b/src/Language/Mulang/Parsers/Java.hs @@ -10,6 +10,7 @@ import Language.Java.Parser import Language.Java.Syntax +import Language.Java.Pretty (prettyPrint) import Control.Fallible @@ -28,35 +29,45 @@ m (CompilationUnit _ _ typeDecls) = compactMap muTypeDecl $ typeDecls -muTypeDecl (ClassTypeDecl decl) = muClassTypeDecl decl +muTypeDecl (ClassTypeDecl decl) = muClassTypeDecl decl muTypeDecl (InterfaceTypeDecl decl) = muInterfaceTypeDecl decl -muClassTypeDecl (ClassDecl _ name _ superclass interfaces (ClassBody body)) = +muClass (ClassDecl _ name _ superclass interfaces (ClassBody body)) = Class (i name) (fmap muRefType superclass) (compact (map muImplements interfaces ++ concatMap muDecl body)) -muClassTypeDecl (EnumDecl _ name _ (EnumBody constants _)) = + +muInterface (InterfaceDecl _ name _ interfaces (InterfaceBody body)) = + Interface (i name) (map muRefType interfaces) (compactConcatMap muMemberDecl body) + +muClassTypeDecl clazz@(ClassDecl _ name args _ _ _) = muDeclaration name args $ muClass clazz + +muClassTypeDecl (EnumDecl _ name _ (EnumBody constants _)) = Enumeration (i name) (map muEnumConstant constants) -muImplements interface = Implement $ muRefType interface +muImplements interface = Implement $ Reference (muRefType interface) -muInterfaceTypeDecl (InterfaceDecl _ name _ interfaces (InterfaceBody body)) = - Interface (i name) (map muRefType interfaces) (compactConcatMap muMemberDecl body ) +muInterfaceTypeDecl interface@(InterfaceDecl _ name args _ _) = muDeclaration name args $ muInterface interface +muDeclaration _ [] decl = decl +muDeclaration name args decl = Sequence [ModuleSignature (i name) (map prettyPrint args), decl] + muDecl :: Decl -> [Expression] muDecl (MemberDecl memberDecl) = muMemberDecl memberDecl -muDecl (InitDecl _ _) = return Other +muDecl e = return . debug $ e muMemberDecl :: MemberDecl -> [Expression] -muMemberDecl (FieldDecl _ _type varDecls) = map (variableToAttribute.muVarDecl) varDecls -muMemberDecl (MethodDecl _ _ typ name params _ (MethodBody Nothing)) = return $ TypeSignature (i name) (map muFormalParamType params) (muMaybeType typ) +muMemberDecl (FieldDecl _ typ varDecls) = concatMap (variableToAttribute.muVarDecl typ) varDecls +muMemberDecl (MethodDecl _ _ typ name params _ (MethodBody Nothing)) = return $ muMethodSignature name params typ muMemberDecl (MethodDecl (elem Static -> True) _ Nothing (Ident "main") [_] _ body) = return $ EntryPoint "main" (muMethodBody body) muMemberDecl (MethodDecl _ _ _ (Ident "equals") params _ body) = return $ EqualMethod [SimpleEquation (map muFormalParam params) (muMethodBody body)] muMemberDecl (MethodDecl _ _ _ (Ident "hashCode") params _ body) = return $ HashMethod [SimpleEquation (map muFormalParam params) (muMethodBody body)] -muMemberDecl (MethodDecl _ _ _ name params _ body) = return $ SimpleMethod (i name) (map muFormalParam params) (muMethodBody body) -muMemberDecl (ConstructorDecl _ _ _ _params _ _constructorBody) = return $ Other +muMemberDecl (MethodDecl _ _ returnType name params _ body) = [ muMethodSignature name params returnType, + SimpleMethod (i name) (map muFormalParam params) (muMethodBody body)] +muMemberDecl e@(ConstructorDecl _ _ _ _params _ _constructorBody) = return . debug $ e muMemberDecl (MemberClassDecl decl) = return $ muClassTypeDecl decl muMemberDecl (MemberInterfaceDecl decl) = return $ muInterfaceTypeDecl decl +muMethodSignature name params returnType = SubroutineSignature (i name) (map muFormalParamType params) (muReturnType returnType) [] muEnumConstant (EnumConstant name _ _) = i name muFormalParam (FormalParam _ _ _ id) = VariablePattern (v id) @@ -66,29 +77,29 @@ muBlockStmt (BlockStmt stmt) = [muStmt stmt] muBlockStmt (LocalClass decl) = [muClassTypeDecl decl] -muBlockStmt (LocalVars _ _type vars) = map muVarDecl vars - -muMaybeType Nothing = "void" -muMaybeType (Just typ) = muType typ +muBlockStmt (LocalVars _ typ vars) = concatMap (muVarDecl typ) vars muType (PrimType t) = muPrimType t muType (RefType t) = muRefType t +muReturnType = fromMaybe "void" . fmap muType muStmt (StmtBlock block) = muBlock block -muStmt (IfThen exp ifTrue) = If (muExp exp) (muStmt ifTrue) MuNull +muStmt (IfThen exp ifTrue) = If (muExp exp) (muStmt ifTrue) None muStmt (IfThenElse exp ifTrue ifFalse) = If (muExp exp) (muStmt ifTrue) (muStmt ifFalse) muStmt (While cond body) = M.While (muExp cond) (muStmt body) -muStmt (Return exp) = M.Return $ fmapOrNull muExp exp +muStmt (Do body cond) = M.While (muStmt body) (muExp cond) +muStmt (Return exp) = M.Return $ fmapOrNone muExp exp muStmt (ExpStmt exp) = muExp exp -muStmt Empty = MuNull +muStmt Empty = None muStmt (Assert exp _) = SimpleSend Self "assert" [muExp exp] muStmt (Synchronized _ block) = muBlock block muStmt (Labeled _ stmt) = muStmt stmt muStmt (Throw exp) = Raise $ muExp exp -muStmt (Try block catches finally) = M.Try (muBlock block) (map muCatch catches) (fmapOrNull muBlock finally) ---muStmt (EnhancedFor _ _ name gen body) = Other -muStmt (Switch exp cases) = muSwitch exp . partition isDefault $ cases -muStmt _ = Other +muStmt (Try block catches finally) = M.Try (muBlock block) (map muCatch catches) (fmapOrNone muBlock finally) +muStmt (BasicFor init cond prog stmt) = ForLoop (fmapOrNone muForInit init) (fmapOrNone muExp cond) (fmapOrNone (compactMap muExp) prog) (muStmt stmt) +muStmt (EnhancedFor _ _ name gen body) = For [Generator (VariablePattern (i name)) (muExp gen)] (muStmt body) +muStmt (Switch exp cases) = muSwitch exp . partition isDefault $ cases +muStmt e = debug e muExp (Lit lit) = muLit lit muExp (MethodInv invoke) = muMethodInvocation invoke @@ -97,11 +108,11 @@ muExp (Cond cond ifTrue ifFalse) = If (muExp cond) (muExp ifTrue) (muExp ifFalse) muExp (ExpName name) = muName name muExp (Assign lhs EqualA exp) = Assignment (muLhs lhs) (muExp exp) -muExp (InstanceCreation _ clazz args _) = New (r clazz) (map muExp args) +muExp (InstanceCreation _ clazz args _) = New (Reference $ r clazz) (map muExp args) muExp (PreNot exp) = SimpleSend (muExp exp) "!" [] muExp (Lambda params exp) = M.Lambda (muLambdaParams params) (muLambdaExp exp) muExp (MethodRef _ message) = M.Lambda [VariablePattern "it"] (SimpleSend (Reference "it") (i message) []) -muExp _ = Other +muExp e = debug e muLambdaExp (LambdaExpression exp) = muExp exp muLambdaExp (LambdaBlock block) = muBlock block @@ -124,7 +135,7 @@ muLit (Double d) = MuNumber d muLit (Boolean b) = MuBool b muLit Null = MuNil -muLit _ = Other +muLit e = debug e muOp Mult = Reference "*" muOp Div = Reference "/" @@ -139,14 +150,16 @@ muOp Or = Reference "||" muOp Equal = M.Equal muOp NotEq = NotEqual -muOp _ = Other +muOp e = debug e -muVarDecl (VarDecl id init) = Variable (v id) (fmapOrNull muVarInit init) +muVarDecl typ (VarDecl id init) = [ + TypeSignature (v id) (SimpleType (muType typ) []), + Variable (v id) (fmapOrNone muVarInit init)] muMethodBody (MethodBody (Just block)) = muBlock block muVarInit (InitExp exp) = muExp exp -muVarInit (InitArray _ArrayInit) = Other +muVarInit e = debug e muMethodInvocation (MethodCall (Name [Ident "System", Ident "out", Ident "println"]) [expr]) = Print (muExp expr) muMethodInvocation (MethodCall (Name [Ident "System", Ident "out", Ident "print"]) [expr]) = Print (muExp expr) @@ -155,29 +168,33 @@ muMethodInvocation (MethodCall (Name [message]) args) = SimpleSend Self (i message) (map muExp args) muMethodInvocation (MethodCall (Name receptorAndMessage) args) = SimpleSend (Reference (ns . init $ receptorAndMessage)) (i . last $ receptorAndMessage) (map muExp args) muMethodInvocation (PrimaryMethodCall receptor _ selector args) = SimpleSend (muExp receptor) (i selector) (map muExp args) -muMethodInvocation _ = Other +muMethodInvocation e = debug e muRefType (ClassRefType clazz) = r clazz muRefType (ArrayType t) = (muType t) ++ "[]" muPrimType = map toLower . dropLast 1 . show -muSwitch exp (def, cases) = M.Switch (muExp exp) (map muCase cases) (headOrElse MuNull . map muDefault $ def) +muSwitch exp (def, cases) = M.Switch (muExp exp) (map muCase cases) (headOrElse None . map muDefault $ def) muCase (SwitchBlock (SwitchCase exp) block) = (muExp exp, compactConcatMap muBlockStmt block) muDefault (SwitchBlock Default block) = compactConcatMap muBlockStmt block +muForInit:: ForInit -> Expression +muForInit (ForLocalVars _ typ varDecls) = compactConcatMap (muVarDecl typ) varDecls +muForInit (ForInitExps exps) = compactMap muExp exps + isDefault (SwitchBlock Default _) = True isDefault _ = False -- Combinators -fmapOrNull f = fromMaybe MuNull . fmap f +fmapOrNone f = fromMaybe None . fmap f -- Helpers -variableToAttribute (Variable id init) = Attribute id init +variableToAttribute [typ, (Variable id init)] = [typ, Attribute id init] v (VarId name) = i name v (VarDeclArray id) = (v id) ++ "[]" diff --git a/src/Language/Mulang/Parsers/JavaScript.hs b/src/Language/Mulang/Parsers/JavaScript.hs --- a/src/Language/Mulang/Parsers/JavaScript.hs +++ b/src/Language/Mulang/Parsers/JavaScript.hs @@ -33,30 +33,36 @@ muJSStatement (JSStatementBlock _ statements _ _) = compactMap muJSStatement statements --muJSStatement (JSConstant _ (JSCommaList JSExpression) _) -- ^const, decl, autosemi muJSStatement (JSDoWhile _ statement _ _ expression _ _) = While (muJSExpression expression) (muJSStatement statement) ---muJSStatement (JSFor _ _ (JSCommaList JSExpression) _ (JSCommaList JSExpression) _ (JSCommaList JSExpression) _ JSStatement) -- ^for,lb,expr,semi,expr,semi,expr,rb.stmt ---muJSStatement (JSForIn _ _ (JSIdentifier _ name) _ JSExpression _ JSStatement) = For [muJSExpression ] ---muJSStatement (JSForVar _ _ _ (JSCommaList JSExpression) _ (JSCommaList JSExpression) _ (JSCommaList JSExpression) _ JSStatement) -- ^for,lb,var,vardecl,semi,expr,semi,expr,rb,stmt ---muJSStatement (JSForVarIn _ _ _ JSExpression _ JSExpression _ JSStatement) -- ^for,lb,var,vardecl,in,expr,rb,stmt +muJSStatement (JSFor _ _ inits _ conds _ progs _ body) = muFor inits conds progs body +muJSStatement (JSForIn _ _ id _ gen _ body) = muForIn id gen body +muJSStatement (JSForVar _ _ _ inits _ conds _ progs _ body) = muFor inits conds progs body +muJSStatement (JSForVarIn _ _ _ (JSVarInitExpression id _) _ gen _ body) = muForIn id gen body muJSStatement (JSFunction _ ident _ params _ body _) = muComputation ident params body -muJSStatement (JSIf _ _ expression _ statement) = If (muJSExpression expression) (muJSStatement statement) MuNull +muJSStatement (JSIf _ _ expression _ statement) = If (muJSExpression expression) (muJSStatement statement) None muJSStatement (JSIfElse _ _ expression _ ifStatement _ elseStatement) = If (muJSExpression expression) (muJSStatement ifStatement) (muJSStatement elseStatement) muJSStatement (JSLabelled _ _ statement) = muJSStatement statement -muJSStatement (JSEmptyStatement _) = MuNull +muJSStatement (JSEmptyStatement _) = None muJSStatement (JSExpressionStatement (JSIdentifier _ val) _) = Reference val muJSStatement (JSExpressionStatement expression _) = muJSExpression expression muJSStatement (JSAssignStatement (JSIdentifier _ name) op value _) = Assignment name (muJSAssignOp op name (muJSExpression value)) muJSStatement (JSMethodCall (JSMemberDot receptor _ message) _ params _ _) = Send (muJSExpression receptor) (muJSExpression message) (map muJSExpression (muJSCommaList params)) muJSStatement (JSMethodCall ident _ params _ _) = Application (muJSExpression ident) (map muJSExpression (muJSCommaList params)) -muJSStatement (JSReturn _ maybeExpression _) = Return (maybe MuNull muJSExpression maybeExpression) +muJSStatement (JSReturn _ maybeExpression _) = Return (maybe None muJSExpression maybeExpression) muJSStatement (JSSwitch _ _ expression _ _ cases _ _) = muSwitch expression . partition isDefault $ cases muJSStatement (JSThrow _ expression _) = Raise (muJSExpression expression) muJSStatement (JSTry _ block catches finally) = Try (muJSBlock block) (map muJSTryCatch catches) (muJSTryFinally finally) muJSStatement (JSVariable _ list _) = compactMap muJSExpression.muJSCommaList $ list muJSStatement (JSWhile _ _ expression _ statement) = While (muJSExpression expression) (muJSStatement statement) -muJSStatement _ = Other +muJSStatement e = debug e -muSwitch expression (def, cases) = Switch (muJSExpression expression) (map muCase cases) (headOrElse MuNull . map muDefault $ def) +muJSExpressionFromList = compactMap muJSExpression . muJSCommaList +muFor inits conds progs body = ForLoop (muJSExpressionFromList inits) (muJSExpressionFromList conds) (muJSExpressionFromList progs) (muJSStatement body) + +muForIn (JSIdentifier _ id) generator body = For [Generator (VariablePattern id) (muJSExpression generator)] (muJSStatement body) + +muSwitch expression (def, cases) = Switch (muJSExpression expression) (map muCase cases) (headOrElse None . map muDefault $ def) + muCase (JSCase _ expression _ statements) = (muJSExpression expression, compactMap muJSStatement statements) muDefault (JSDefault _ _ statements) = compactMap muJSStatement statements @@ -84,7 +90,7 @@ muJSExpression:: JSExpression -> Expression -muJSExpression (JSIdentifier _ "undefined") = MuNull +muJSExpression (JSIdentifier _ "undefined") = None muJSExpression (JSIdentifier _ name) = Reference name muJSExpression (JSDecimal _ val) = MuNumber (read val) muJSExpression (JSLiteral _ "null") = MuNil @@ -107,14 +113,14 @@ muJSExpression (JSFunctionExpression _ ident _ params _ body) = muComputation ident params body --muJSExpression (JSMemberDot JSExpression _ JSExpression) -- ^firstpart, dot, name muJSExpression (JSMemberExpression id _ params _) = Application (muJSExpression id) (map muJSExpression.muJSCommaList $ params) -muJSExpression (JSMemberNew _ (JSIdentifier _ name) _ args _) = New name (map muJSExpression.muJSCommaList $ args) +muJSExpression (JSMemberNew _ (JSIdentifier _ name) _ args _) = New (Reference name) (map muJSExpression.muJSCommaList $ args) --muJSExpression (JSMemberSquare JSExpression _ JSExpression _) -- ^firstpart, lb, expr, rb -muJSExpression (JSNewExpression _ (JSIdentifier _ name)) = New name [] +muJSExpression (JSNewExpression _ (JSIdentifier _ name)) = New (Reference name) [] muJSExpression (JSObjectLiteral _ propertyList _) = MuObject (compactMap id.map muJSObjectProperty.muJSCommaTrailingList $ propertyList) muJSExpression (JSUnaryExpression (JSUnaryOpNot _) e) = Application (Reference "!") [muJSExpression e] muJSExpression (JSUnaryExpression op (JSIdentifier _ name)) = Assignment name (muJSUnaryOp op name) muJSExpression (JSVarInitExpression (JSIdentifier _ name) initial) = Variable name (muJSVarInitializer initial) -muJSExpression _ = Other +muJSExpression e = debug e removeQuotes = filter (flip notElem quoteMarks) where quoteMarks = "\"'" @@ -152,7 +158,7 @@ --muJSUnaryOp (JSUnaryOpTilde _) --muJSUnaryOp (JSUnaryOpTypeof _) --muJSUnaryOp (JSUnaryOpVoid _) -muJSUnaryOp _ _ = Other +muJSUnaryOp e _ = debug e muJSAssignOp:: JSAssignOp -> Identifier -> Expression -> Expression muJSAssignOp (JSAssign _) _ v = v @@ -170,16 +176,16 @@ muJSAssignOp' (JSBwAndAssign _) = Reference "&" muJSAssignOp' (JSBwXorAssign _) = Reference "^" muJSAssignOp' (JSBwOrAssign _) = Reference "|" -muJSAssignOp' _ = Other +muJSAssignOp' e = debug e muJSTryCatch:: JSTryCatch -> (Pattern, Expression) --muJSTryCatch JSCatch _ _ JSExpression _ JSBlock -- ^catch,lb,ident,rb,block --muJSTryCatch JSCatchIf _ _ JSExpression _ JSExpression _ JSBlock -- ^catch,lb,ident,if,expr,rb,block -muJSTryCatch _ = (WildcardPattern, Other) +muJSTryCatch e = (WildcardPattern, debug e) muJSTryFinally:: JSTryFinally -> Expression muJSTryFinally (JSFinally _ block) = muJSBlock block -muJSTryFinally JSNoFinally = MuNull +muJSTryFinally JSNoFinally = None muJSBlock:: JSBlock -> Expression muJSBlock (JSBlock _ statements _) = compactMap muJSStatement statements @@ -187,14 +193,14 @@ muJSVarInitializer:: JSVarInitializer -> Expression muJSVarInitializer (JSVarInit _ expression) = muJSExpression expression --muJSVarInitializer JSVarInitNone -muJSVarInitializer _ = Other +muJSVarInitializer e = debug e muJSObjectProperty:: JSObjectProperty -> Expression --muJSObjectProperty JSPropertyAccessor JSAccessor JSPropertyName _ [JSExpression] _ JSBlock -- ^(get|set), name, lb, params, rb, block muJSObjectProperty (JSPropertyNameandValue id _ [JSFunctionExpression _ _ _ params _ block]) = Method (muJSPropertyName id) (muEquation (map muPattern (muJSCommaList params)) (muJSBlock block)) muJSObjectProperty (JSPropertyNameandValue id _ [expression]) = Variable (muJSPropertyName id) (muJSExpression expression) -muJSObjectProperty _ = Other +muJSObjectProperty e = debug e muJSPropertyName:: JSPropertyName -> Identifier muJSPropertyName = removeQuotes.muJSPropertyName' @@ -203,11 +209,6 @@ muJSPropertyName' (JSPropertyIdent _ name) = name muJSPropertyName' (JSPropertyString _ name) = name muJSPropertyName' (JSPropertyNumber _ name) = name - -muJSAccessor:: JSAccessor -> Expression ---muJSAccessor JSAccessorGet _ ---muJSAccessor JSAccessorSet _ -muJSAccessor _ = Other muJSArrayList:: [JSArrayElement] -> [Expression] muJSArrayList list = [muJSExpression expression | (JSArrayElement expression) <- list] diff --git a/src/Language/Mulang/Parsers/Python.hs b/src/Language/Mulang/Parsers/Python.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Parsers/Python.hs @@ -0,0 +1,227 @@ +module Language.Mulang.Parsers.Python (py, parsePython) where + +import qualified Language.Mulang.Ast as M +import Language.Mulang.Builder +import Language.Mulang.Parsers + +import Language.Python.Version3.Parser (parseModule) +import Language.Python.Common.Token (Token) +import Language.Python.Common.AST + +import Data.List (intercalate) +import Data.Maybe (fromMaybe, listToMaybe) + +import Control.Fallible + +py:: Parser +py = orFail . parsePython' + +parsePython:: EitherParser +parsePython = orLeft . parsePython' + +parsePython' = fmap (normalize . muPyAST) . (`parseModule` "") + +muPyAST:: (ModuleSpan, [Token]) -> M.Expression +muPyAST (modul, _) = muModule modul + +muModule:: ModuleSpan -> M.Expression +muModule (Module statements) = compactMap muStatement statements + + +muStatement:: StatementSpan -> M.Expression +muStatement (While cond body _ _) = M.While (muExpr cond) (muSuite body) +muStatement (For targets generator body _ _) = M.For [M.Generator (M.TuplePattern (map (M.VariablePattern . muVariable) targets)) (muExpr generator)] (muSuite body) +muStatement (Fun name args _ body _) = muComputation (muIdent name) (map muParameter args) (muSuite body) +muStatement (Class name parents body _) = M.Class (muIdent name) (listToMaybe . map muParent $ parents) (muSuite body) +muStatement (Conditional guards els _ ) = foldr muIf (muSuite els) guards +muStatement (Assign [to] from _) = M.Assignment (muVariable to) (muExpr from) +muStatement (AugmentedAssign to op from _) = M.Assignment (muVariable to) (M.Application (M.Reference . muAssignOp $ op) [M.Reference . muVariable $ to, muExpr from]) +--muStatement (Decorated +-- { decorated_decorators :: [Decorator annot] -- ^ Decorators. +-- , decorated_def :: Statement annot -- ^ Function or class definition to be decorated. +-- , stmt_annot :: annot +-- } +muStatement (Return expr _) = M.Return $ fmapOrNull muExpr expr +muStatement (Try body handlers _ finally _) = M.Try (muSuite body) (map muHandler handlers) (muSuite finally) +muStatement (Raise expr _) = M.Raise $ muRaiseExpr expr +--muStatement (With +-- { with_context :: [(Expr annot, Maybe (Expr annot))] -- ^ Context expression(s) (yields a context manager). +-- , with_body :: Suite annot -- ^ Suite to be managed. +-- , stmt_annot :: annot +-- } +muStatement (Pass _) = M.None +--muStatement (Break { stmt_annot :: annot } +--muStatement (Continue { stmt_annot :: annot } +--muStatement (Delete +-- { del_exprs :: [Expr annot] -- ^ Items to delete. +-- , stmt_annot :: annot +-- } +muStatement (StmtExpr expr _) = muExpr expr +--muStatement (Global +-- { global_vars :: [Ident annot] -- ^ Variables declared global in the current block. +-- , stmt_annot :: annot +-- } +--muStatement (NonLocal +-- { nonLocal_vars :: [Ident annot] -- ^ Variables declared nonlocal in the current block (their binding comes from bound the nearest enclosing scope). +-- , stmt_annot :: annot +-- } +--muStatement (Assert +-- { assert_exprs :: [Expr annot] -- ^ Expressions being asserted. +-- , stmt_annot :: annot +-- } +muStatement (Print _ exprs _ _) = M.Print $ compactMap muExpr exprs +muStatement (Exec expr _ _) = muExpr expr +muStatement e = M.debug e + + +muIf (condition, body) otherwise = M.If (muExpr condition) (muSuite body) otherwise + +muParent (ArgExpr (Var ident _) _) = muIdent ident + +muComputation name params body | containsReturn body = M.SimpleFunction name params body + | otherwise = M.SimpleProcedure name params body + + +containsReturn :: M.Expression -> Bool +containsReturn (M.Return _) = True +containsReturn (M.Sequence xs) = any containsReturn xs +containsReturn _ = False + +muParameter:: ParameterSpan -> M.Pattern +muParameter (Param name _ _ _) = M.VariablePattern (muIdent name) + +muIdent:: IdentSpan -> String +muIdent (Ident id _) = id + +muSuite:: SuiteSpan -> M.Expression +muSuite = compactMap muStatement + + +muExpr:: ExprSpan -> M.Expression +muExpr (Var ident _) = M.Reference (muIdent ident) +muExpr (Int value _ _) = muNumberFromInt value +muExpr (LongInt value _ _) = muNumberFromInt value +muExpr (Float value _ _) = M.MuNumber value +--muExpr (Imaginary { imaginary_value :: Double, expr_literal :: String, expr_annot :: annot } +muExpr (Bool value _) = M.MuBool value +muExpr (None _) = M.MuNil +--muExpr (Ellipsis { expr_annot :: annot } +--muExpr (ByteStrings { byte_string_strings :: [String], expr_annot :: annot } +muExpr (Strings strings _) = muString strings +muExpr (UnicodeStrings strings _) = muString strings +muExpr (Call fun args _) = muCallType fun (map muArgument args) +--muExpr (Subscript { subscriptee :: Expr annot, subscript_expr :: Expr annot, expr_annot :: annot } +--muExpr (SlicedExpr { slicee :: Expr annot, slices :: [Slice annot], expr_annot :: annot } +--muExpr (CondExpr +-- { ce_true_branch :: Expr annot -- ^ Expression to evaluate if condition is True. +-- , ce_condition :: Expr annot -- ^ Boolean condition. +-- , ce_false_branch :: Expr annot -- ^ Expression to evaluate if condition is False. +-- , expr_annot :: annot +-- } +muExpr (BinaryOp op left right _) = muApplication op [left, right] +muExpr (UnaryOp op arg _) = muApplication op [arg] +--muExpr (Dot { dot_expr :: Expr annot, dot_attribute :: Ident annot, expr_annot :: annot } +muExpr (Lambda args body _) = M.Lambda (map muParameter args) (muExpr body) +muExpr (Tuple exprs _) = M.MuTuple $ map muExpr exprs +muExpr (Yield arg _) = M.Yield $ fmapOrNull muYieldArg arg +--muExpr (Generator { gen_comprehension :: Comprehension annot, expr_annot :: annot } +--muExpr (ListComp { list_comprehension :: Comprehension annot, expr_annot :: annot } +muExpr (List exprs _) = muList exprs +--muExpr (Dictionary { dict_mappings :: [DictMappingPair annot], expr_annot :: annot } +--muExpr (DictComp { dict_comprehension :: Comprehension annot, expr_annot :: annot } +muExpr (Set exprs _) = muList exprs +--muExpr (SetComp { set_comprehension :: Comprehension annot, expr_annot :: annot } +--muExpr (Starred { starred_expr :: Expr annot, expr_annot :: annot } +muExpr (Paren expr _) = muExpr expr +--muExpr (StringConversion { backquoted_expr :: Expr annot, expr_anot :: annot } +muExpr e = M.debug e + + +muList = M.MuList . map muExpr + +muCallType (Dot receiver ident _) = muCall (M.Send $ muExpr receiver) ident +muCallType (Var ident _) = muCall M.Application ident + +muCall callType ident = callType (M.Reference $ muIdent ident) + + +muApplication op args = M.Application (M.Reference (muOp op)) (map muExpr args) + +muString = M.MuString . intercalate "\n" + +muNumberFromInt = M.MuNumber . fromInteger + +muVariable:: ExprSpan -> M.Identifier +muVariable (Var ident _) = muIdent ident + +muArgument (ArgExpr expr _) = muExpr expr +muArgument (ArgVarArgsPos expr _ ) = muExpr expr +muArgument (ArgVarArgsKeyword expr _ ) = muExpr expr +--muArgument ArgKeyword +-- { arg_keyword :: Ident annot -- ^ Keyword name. +-- , arg_expr :: Expr annot -- ^ Argument expression. +-- , arg_annot :: annot +-- } +muArgument e = M.debug e + +--muYieldArg (YieldFrom expr _)(Expr annot) annot -- ^ Yield from a generator (Version 3 only) +muYieldArg (YieldExpr expr) = muExpr expr + +muOp (And _) = "and" +muOp (Or _) = "or" +muOp (Not _) = "not" +muOp (Exponent _) = "**" +muOp (LessThan _) = "<" +muOp (GreaterThan _) = ">" +muOp (Equality _) = "==" +muOp (GreaterThanEquals _) = ">=" +muOp (LessThanEquals _) = "<=" +muOp (NotEquals _) = "!=" +muOp (NotEqualsV2 _) = "<>" -- Version 2 only. +muOp (In _) = "in" +muOp (Is _) = "is" +muOp (IsNot _) = "is not" +muOp (NotIn _) = "not in" +muOp (BinaryOr _) = "|" +muOp (Xor _) = "^" +muOp (BinaryAnd _) = "&" +muOp (ShiftLeft _) = "<<" +muOp (ShiftRight _) = ">>" +muOp (Multiply _) = "*" +muOp (Plus _) = "+" +muOp (Minus _) = "-" +muOp (Divide _) = "/" +muOp (FloorDivide _) = "//" +muOp (Invert _) = "~" +muOp (Modulo _) = "%" + +muAssignOp (PlusAssign _) = "+" +muAssignOp (MinusAssign _) = "-" +muAssignOp (MultAssign _) = "*" +muAssignOp (DivAssign _) = "/" +muAssignOp (ModAssign _) = "%" +muAssignOp (PowAssign _) = "**" +muAssignOp (BinAndAssign _) = "&" +muAssignOp (BinOrAssign _) = "|" +muAssignOp (BinXorAssign _) = "^" +muAssignOp (LeftShiftAssign _) = "<" +muAssignOp (RightShiftAssign _) = ">" +muAssignOp (FloorDivAssign _) = "/" + +muHandler (Handler (ExceptClause clause _) suite _) = (muExceptClause clause, muSuite suite) + +muExceptClause Nothing = M.WildcardPattern +muExceptClause (Just (except, maybeVar)) = muPattern maybeVar (M.TypePattern $ muVarToId except) + +muPattern Nothing = id +muPattern (Just var) = M.AsPattern (muVarToId var) + +muRaiseExpr (RaiseV3 Nothing) = M.None +muRaiseExpr (RaiseV3 (Just (expr, _))) = muExpr expr +--muRaiseExpr RaiseV2 (Maybe (Expr annot, (Maybe (Expr annot, Maybe (Expr annot))))) -- ^ /Version 2 only/. + +-- Helpers + +fmapOrNull f = fromMaybe M.None . fmap f + +muVarToId (Var ident _) = muIdent ident diff --git a/src/Language/Mulang/Signature.hs b/src/Language/Mulang/Signature.hs --- a/src/Language/Mulang/Signature.hs +++ b/src/Language/Mulang/Signature.hs @@ -49,17 +49,22 @@ parameterNames (NamedSignature _ names) = names signaturesOf :: Expression -> [Signature] -signaturesOf = nub . mapMaybe (signatureOf.snd) . declarations +signaturesOf = nub . mapMaybe signatureOf . declarations signatureOf :: Expression -> Maybe Signature -signatureOf (Subroutine name es) = Just $ NamedSignature name (parameterNamesOf es) -signatureOf (Clause name args _) = Just $ AritySignature name (length args) -signatureOf (TypeSignature name args ret) = Just $ TypedSignature name args ret -signatureOf (Variable name _) = Just $ AritySignature name 0 -signatureOf _ = Nothing +signatureOf (Subroutine name es) = Just $ NamedSignature name (parameterNamesOf es) +signatureOf (Clause name args _) = Just $ AritySignature name (length args) +signatureOf (TypeSignature name t) = typedSignatureOf name t +signatureOf (Variable name _) = Just $ AritySignature name 0 +signatureOf _ = Nothing +typedSignatureOf :: Identifier -> Type -> Maybe Signature +typedSignatureOf name (ParameterizedType args ret []) = Just $ TypedSignature name args ret +typedSignatureOf name (SimpleType ret []) = Just $ TypedSignature name [] ret +typedSignatureOf _ _ = Nothing + parameterNamesOf :: [Equation] -> [Maybe Identifier] -parameterNamesOf = map msum . transpose . map (map parameterNameOf . equationParams) +parameterNamesOf = map msum . transpose . map (map parameterNameOf . equationPatterns) parameterNameOf :: Pattern -> Maybe Identifier parameterNameOf (VariablePattern v) = Just v