diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Franco Leonardo Bulgarelli + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mulang.cabal b/mulang.cabal new file mode 100644 --- /dev/null +++ b/mulang.cabal @@ -0,0 +1,56 @@ +name: mulang +version: 0.1.0.0 +synopsis: The Mu Language, a non-computable extended Lambda Calculus +-- description: +license: MIT +license-file: LICENSE +author: Franco Leonardo Bulgarelli +maintainer: franco@mumuki.org +category: Language +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: base >=4.6 && <4.7 + default-language: Haskell2010 + ghc-options: + -Wall + -fno-warn-missing-signatures + -fno-warn-orphans + -fno-warn-name-shadowing + hs-source-dirs: + src + exposed-modules: + Language.Mulang + Language.Mulang.Explorer + Language.Mulang.Inspector.Smell + Language.Mulang.Inspector.Combiner + Language.Mulang.Inspector + Language.Mulang.Parsers.Haskell + Language.Mulang.Parsers.Json + build-depends: + base >= 4 && < 5, + bytestring == 0.10.6.0, + haskell-src >= 1 && < 1.1, + aeson == 0.8.1.1 + + +test-suite spec + type: + exitcode-stdio-1.0 + ghc-options: + -Wall + -fno-warn-missing-signatures + -fno-warn-orphans + -fno-warn-name-shadowing + hs-source-dirs: + spec + main-is: + Spec.hs + build-depends: + base >= 4 && < 5, + bytestring == 0.10.6.0, + aeson == 0.8.1.1, + haskell-src >= 1 && < 1.1, + hspec >= 2 && < 3, + mulang diff --git a/spec/Spec.hs b/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/spec/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/Language/Mulang.hs b/src/Language/Mulang.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Language.Mulang ( + Program(..), + Declaration(..), + Equation(..), + Rhs(..), + GuardedRhs(..), + Expression(..), + ComprehensionStatement(..), + Alternative(..), + GuardedAlternatives(..), + GuardedAlternative(..), + Pattern(..), + LiteralValue(..) + ) where + +import GHC.Generics + +data Program = Program [Declaration] deriving (Eq, Show, Read, Generic) + +type Identifier = String + +-- declaration or directive +data Declaration + = TypeAlias Identifier + | RecordDeclaration Identifier + | TypeSignature Identifier + | FunctionDeclaration Identifier [Equation] -- functional, maybe pure, + -- optionally guarded, + -- optionally pattern matched function + | ProcedureDeclaration Identifier -- classic imperative-style procedure + | ConstantDeclaration Identifier Rhs [Declaration] + deriving (Eq, Show, Read, Generic) + +data Equation = Equation [Pattern] Rhs [Declaration] deriving (Eq, Show, Read, Generic) + +data Rhs + = UnguardedRhs Expression + | GuardedRhss [GuardedRhs] + deriving (Eq, Show, Read, Generic) + +data GuardedRhs = GuardedRhs Expression Expression deriving (Eq, Show, Read, Generic) + +-- expression or statement +-- may have effects +data Expression + = Variable Identifier + | Literal LiteralValue + | InfixApplication Expression String Expression + | Application Expression Expression + | Lambda [Pattern] Expression + | Let [Declaration] Expression + | If Expression Expression Expression + | Match Expression [Alternative] + | MuTuple [Expression] + | MuList [Expression] + | Comprehension Expression [ComprehensionStatement] + | Sequence [Expression] -- sequence of statements + | ExpressionOther + deriving (Eq, Show, Read, Generic) + +data Pattern + = VariablePattern String -- ^ variable + | LiteralPattern String -- ^ literal constant + | InfixApplicationPattern Pattern String Pattern + | ApplicationPattern String [Pattern] -- ^ data constructor and argument + | TuplePattern [Pattern] -- ^ tuple pattern + | ListPattern [Pattern] -- ^ list pattern + | AsPattern String Pattern -- ^ @\@@-pattern + | WildcardPattern -- ^ wildcard pattern (@_@) + | OtherPattern + deriving (Eq, Show, Read, Generic) + +data ComprehensionStatement + = MuGenerator Pattern Expression + | MuQualifier Expression + | LetStmt [Declaration] + deriving (Eq, Show, Read, Generic) + + +data Alternative = Alternative Pattern GuardedAlternatives [Declaration] deriving (Eq, Show, Read, Generic) + +data GuardedAlternatives + = UnguardedAlternative Expression -- ^ @->@ /exp/ + | GuardedAlternatives [GuardedAlternative] -- ^ /gdpat/ + deriving (Eq, Show, Read, Generic) + + +data GuardedAlternative = GuardedAlternative Expression Expression deriving (Eq, Show, Read, Generic) + +data LiteralValue + = MuBool Bool + | MuInteger Integer + | MuFloat Rational + | MuString String + deriving (Eq, Show, Read, Generic) diff --git a/src/Language/Mulang/Explorer.hs b/src/Language/Mulang/Explorer.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Explorer.hs @@ -0,0 +1,92 @@ +module Language.Mulang.Explorer ( + parseDecls, + parseBindings, + declsOf, + rhssOf, + bindingsOf, + transitiveBindingsOf, + expressionsOf, + expressionToBinding, + Expression(..), + Binding) where + +import Language.Mulang +import Data.Maybe (maybeToList) +import Data.List (nub) + +type Binding = String + +declName :: Declaration -> String +declName (TypeSignature b ) = b +declName (TypeAlias b ) = b +declName (ConstantDeclaration n _ _) = n +declName (FunctionDeclaration n _) = n +declName _ = [] + +declsOf :: Binding -> Program -> [Declaration] +declsOf binding = filter (isBinding binding) . parseDecls + +rhssOf :: Binding -> Program -> [Rhs] +rhssOf binding = concatMap rhsForBinding . declsOf binding + +expressionsOf :: Binding -> Program -> [Expression] +expressionsOf binding code = do + rhs <- rhssOf binding code + top <- topExpressions rhs + unfoldExpression top + +bindingsOf :: Binding -> Program -> [Binding] +bindingsOf binding code = nub $ do + expr <- expressionsOf binding code + maybeToList . expressionToBinding $ expr + +transitiveBindingsOf :: Binding -> Program -> [Binding] +transitiveBindingsOf binding code = expand (`bindingsOf` code) binding + +parseDecls :: Program -> [Declaration] +parseDecls (Program decls) = decls + +parseBindings :: Program -> [Binding] +parseBindings = map declName . parseDecls + +expressionToBinding :: Expression -> Maybe Binding +expressionToBinding (Variable q) = Just q +expressionToBinding _ = Nothing + +-- private + +topExpressions :: Rhs -> [Expression] +topExpressions (UnguardedRhs e) = [e] +topExpressions (GuardedRhss rhss) = rhss >>= \(GuardedRhs es1 es2) -> [es1, es2] + +unfoldExpression :: Expression -> [Expression] +unfoldExpression expr = expr : concatMap unfoldExpression (subExpressions expr) + +subExpressions :: Expression -> [Expression] +subExpressions (InfixApplication a b c) = [a, (Variable b), c] +subExpressions (Application a b) = [a, b] +subExpressions (Lambda _ a) = [a] +subExpressions (MuList as) = as +subExpressions (Comprehension a _) = [a] --TODO +subExpressions (MuTuple as) = as +subExpressions (If a b c) = [a, b, c] +subExpressions _ = [] + +isBinding :: Binding -> Declaration -> Bool +isBinding binding = (==binding).declName + +rhsForBinding :: Declaration -> [Rhs] +rhsForBinding (ConstantDeclaration _ rhs localDecls) = concatRhs rhs localDecls +rhsForBinding (FunctionDeclaration _ cases) = cases >>= \(Equation _ rhs localDecls) -> concatRhs rhs localDecls +rhsForBinding _ = [] + +concatRhs rhs l = [rhs] ++ concatMap rhsForBinding l + + +expand :: Eq a => (a-> [a]) -> a -> [a] +expand f x = expand' [] f [x] + +expand' _ _ [] = [] +expand' ps f (x:xs) | elem x ps = expand' ps f xs + | otherwise = [x] ++ expand' (x:ps) f (xs ++ f x) + diff --git a/src/Language/Mulang/Inspector.hs b/src/Language/Mulang/Inspector.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Inspector.hs @@ -0,0 +1,133 @@ +module Language.Mulang.Inspector ( + hasComposition, + hasGuards, + hasIf, + hasConditional, + hasLambda, + hasDirectRecursion, + hasUsage, + hasComprehension, + hasBinding, + hasFunctionDeclaration, + hasArity, + hasTypeDeclaration, + hasTypeSignature, + hasAnonymousVariable, + hasExpression, + hasDecl, + hasRhs, + Inspection, + GlobalInspection + ) where + +import Language.Mulang +import Language.Mulang.Explorer + +type Inspection = Binding -> Program -> Bool +type GlobalInspection = Program -> Bool + +-- | Inspection that tells whether a binding uses the composition operator '.' +-- in its definition +hasComposition :: Inspection +hasComposition = hasExpression f + where f (Variable ".") = True + f _ = False + +-- | Inspection that tells whether a binding uses guards +-- in its definition +hasGuards :: Inspection +hasGuards = hasRhs f + where f (GuardedRhss _) = True + f _ = False + +-- | Inspection that tells whether a binding uses ifs +-- in its definition +hasIf :: Inspection +hasIf = hasExpression f + where f (If _ _ _) = True + f _ = False + +-- | Inspection that tells whether a binding uses ifs or guards +-- in its definition +hasConditional :: Inspection +hasConditional target code = hasIf target code || hasGuards target code + +-- | Inspection that tells whether a binding uses a lambda expression +-- in its definition +hasLambda :: Inspection +hasLambda = hasExpression f + where f (Lambda _ _) = True + f _ = False + + +-- | Inspection that tells whether a binding is direct recursive +hasDirectRecursion :: Inspection +hasDirectRecursion binding = hasUsage binding binding + +-- | Inspection that tells whether a binding uses the the given target binding +-- in its definition +hasUsage :: String -> Inspection +hasUsage target = hasExpression f + where f expr | (Just n) <- expressionToBinding expr = n == target + | otherwise = False + +-- | Inspection that tells whether a binding uses +-- comprehensions - list comprehension, for comprehension, do-syntax, etc - +-- in its definitions +hasComprehension :: Inspection +hasComprehension = hasExpression f + where f (Comprehension _ _) = True + f _ = False + +-- | Inspection that tells whether a top level binding exists +hasBinding :: Inspection +hasBinding binding = not.null.rhssOf binding + +hasFunctionDeclaration :: Inspection +hasFunctionDeclaration funBinding = has f (declsOf funBinding) + where f (FunctionDeclaration _ _) = True + f (ConstantDeclaration _ (UnguardedRhs (Lambda _ _)) _) = True + f (ConstantDeclaration _ (UnguardedRhs (Variable _)) _) = True -- not actually always true + f _ = False + +hasArity :: Int -> Inspection +hasArity arity funBinding = has f (declsOf funBinding) + where f (FunctionDeclaration _ equations) = any equationHasArity equations + f (ConstantDeclaration _ (UnguardedRhs (Lambda args _)) _) = argsHaveArity args + f _ = False + + equationHasArity = \(Equation args _ _) -> argsHaveArity args + + argsHaveArity args = length args == arity + +hasTypeDeclaration :: Inspection +hasTypeDeclaration binding = hasDecl f + where f (TypeAlias name) = binding == name + f _ = False + +hasTypeSignature :: Inspection +hasTypeSignature binding = hasDecl f + where f (TypeSignature name) = binding == name + f _ = False + +hasAnonymousVariable :: Inspection +hasAnonymousVariable binding = has f (declsOf binding) + where f (FunctionDeclaration _ equations) = any (any (== WildcardPattern) . p) equations + f _ = False + p (Equation params _ _) = params + +hasExpression :: (Expression -> Bool) -> Inspection +hasExpression f binding = has f (expressionsOf binding) + +hasRhs :: (Rhs -> Bool)-> Inspection +hasRhs f binding = has f (rhssOf binding) + +hasDecl :: (Declaration -> Bool) -> GlobalInspection +hasDecl f = has f parseDecls + +-- private + +has f g = any f . g + + + diff --git a/src/Language/Mulang/Inspector/Combiner.hs b/src/Language/Mulang/Inspector/Combiner.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Inspector/Combiner.hs @@ -0,0 +1,18 @@ +module Language.Mulang.Inspector.Combiner ( + detect, + negative, + transitive) where + +import Language.Mulang +import Language.Mulang.Inspector +import Language.Mulang.Explorer + +detect :: Inspection -> Program -> [Binding] +detect inspection code = filter (`inspection` code) $ parseBindings code + +negative :: Inspection -> Inspection +negative f code = not . f code + +transitive :: Inspection -> Inspection +transitive inspection binding code = inspection binding code || inUsage + where inUsage = any (`inspection` code) . transitiveBindingsOf binding $ code diff --git a/src/Language/Mulang/Inspector/Smell.hs b/src/Language/Mulang/Inspector/Smell.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Inspector/Smell.hs @@ -0,0 +1,54 @@ +module Language.Mulang.Inspector.Smell ( + hasRedundantBooleanComparison, + hasRedundantIf, + hasRedundantGuards, + hasRedundantLambda, + hasRedundantParameter) where + +import Language.Mulang +import Language.Mulang.Explorer +import Language.Mulang.Inspector + + +-- | Inspection that tells whether a binding has expressions like 'x == True' +hasRedundantBooleanComparison :: Inspection +hasRedundantBooleanComparison = hasExpression f + where f (InfixApplication x c y) = any isBooleanLiteral [x, y] && isComp c + f _ = False + + isComp c = c == "==" || c == "/=" + +-- | Inspection that tells whether a binding has an if expression where both branches return +-- boolean literals +hasRedundantIf :: Inspection +hasRedundantIf = hasExpression f + where f (If _ x y) = all isBooleanLiteral [x, y] + f _ = False + + +-- | Inspection that tells whether a binding has guards where both branches return +-- boolean literals +hasRedundantGuards :: Inspection +hasRedundantGuards = hasRhs f -- TODO not true when condition is a pattern + where f (GuardedRhss [ + GuardedRhs _ x, + GuardedRhs (Variable "otherwise") y]) = all isBooleanLiteral [x, y] + f _ = False + + +-- | Inspection that tells whether a binding has lambda expressions like '\x -> g x' +hasRedundantLambda :: Inspection +hasRedundantLambda = hasExpression f + where f (Lambda [VariablePattern (x)] (Application _ (Variable (y)))) = x == y + f _ = False -- TODO consider parenthesis and symbols + +-- | Inspection that tells whether a binding has parameters that +-- can be avoided using point-free +hasRedundantParameter :: Inspection +hasRedundantParameter binding = any f . declsOf binding + where f (FunctionDeclaration _ [ + Equation params (UnguardedRhs (Application _ (Variable arg))) _ ]) | (VariablePattern param) <- last params = param == arg + f _ = False + +isBooleanLiteral (Literal (MuBool _)) = True +isBooleanLiteral _ = False diff --git a/src/Language/Mulang/Parsers/Haskell.hs b/src/Language/Mulang/Parsers/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Parsers/Haskell.hs @@ -0,0 +1,98 @@ +module Language.Mulang.Parsers.Haskell (parseHaskell) where + +import Language.Mulang +import Language.Haskell.Syntax +import Language.Haskell.Parser + +import Data.String (IsString(..)) +import Data.Maybe (fromJust) +import Data.List (intercalate) + +instance IsString Program where + fromString = fromJust.parseHaskell + +parseHaskell :: String -> Maybe Program +parseHaskell code | ParseOk ast <- parseModule code = Just (mu ast) + | otherwise = Nothing + +mu :: HsModule -> Program +mu (HsModule _ _ _ _ decls) = (Program (concatMap muDecls decls)) + where + muDecls (HsTypeDecl _ name _ _) = [TypeAlias (muName name)] + muDecls (HsDataDecl _ _ name _ _ _ ) = [RecordDeclaration (muName name)] + muDecls (HsTypeSig _ names _) = map (\name -> TypeSignature (muName name)) names + muDecls (HsFunBind equations) | (HsMatch _ name _ _ _) <- head equations = + [FunctionDeclaration (muName name) (map muEquation equations)] + muDecls (HsPatBind _ (HsPVar name) rhs decls) = [ConstantDeclaration (muName name) (muRhs rhs) (concatMap muDecls decls)] + muDecls _ = [] + + muEquation :: HsMatch -> Equation + muEquation (HsMatch _ _ patterns rhs locals) = + Equation (map muPat patterns) (muRhs rhs) (concatMap muDecls locals) + + muRhs (HsUnGuardedRhs exp) = UnguardedRhs (muExp exp) + muRhs (HsGuardedRhss guards) = GuardedRhss (map muGuardedRhs guards) + + muGuardedRhs (HsGuardedRhs _ condition body) = (GuardedRhs (muExp condition) (muExp body)) + + muPat (HsPVar name) = VariablePattern (muName name) -- ^ variable + muPat (HsPLit _) = LiteralPattern "" -- ^ literal constant + --Pattern HsPInfixApp = InfixApplicationPattern Pattern MuQName Pattern + --Pattern HsPApp = ApplicationPattern MuQName [Pattern] -- ^ data constructor and argument + muPat (HsPTuple elements) = TuplePattern (map muPat elements) + muPat (HsPList elements) = ListPattern (map muPat elements) + muPat (HsPParen pattern) = muPat pattern + --Pattern HsPAsPat = AsPattern String Pattern + muPat HsPWildCard = WildcardPattern + muPat _ = OtherPattern + + muExp (HsVar name) = Variable (muQName name) + muExp (HsCon (UnQual (HsIdent "True"))) = Literal (MuBool True) + muExp (HsCon (UnQual (HsIdent "False"))) = Literal (MuBool False) + muExp (HsCon name) = Variable (muQName name) + muExp (HsLit lit) = Literal (muLit lit) + muExp (HsInfixApp e1 op e2) = InfixApplication (muExp e1) (muQOp op) (muExp e2) -- ^ infix application + muExp (HsApp e1 e2) = Application (muExp e1) (muExp e2) -- ^ ordinary application + muExp (HsNegApp e) = Application (Variable "-") (muExp e) + muExp (HsLambda _ args exp) = Lambda (map muPat args) (muExp exp) + --muExp HsLet = Let [Declaration] Expression -- ^ local declarations with @let@ + muExp (HsIf e1 e2 e3) = If (muExp e1) (muExp e2) (muExp e3) + --muExp HsMatch = Match Expression [Alternative] -- ^ @case@ /exp/ @of@ /alts/ + muExp (HsTuple elements) = MuTuple (map muExp elements) -- ^ tuple Expression + muExp (HsList elements) = MuList (map muExp elements) + muExp (HsParen e) = (muExp e) + muExp (HsEnumFrom from) = Application (Variable "enumFrom") (muExp from) + muExp (HsEnumFromTo from to) = Application (Application (Variable "enumFromTo") (muExp from)) (muExp to) + muExp (HsEnumFromThen from thn) = Application (Application (Variable "enumFromThen") (muExp from)) (muExp thn) + muExp (HsEnumFromThenTo from thn to) = Application (Application (Application (Variable "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 _ = ExpressionOther + + muLit (HsChar v) = MuString [v] + muLit (HsString v) = MuString v + muLit (HsInt v) = MuInteger v + muLit (HsFrac v) = MuFloat v + muLit (HsCharPrim v) = MuString [v] + muLit (HsStringPrim v) = MuString v + muLit (HsIntPrim v) = MuInteger v + muLit (HsFloatPrim v) = MuFloat v + muLit (HsDoublePrim v) = MuFloat v + + muName :: HsName -> String + muName (HsSymbol n) = n + muName (HsIdent n) = n + + muQName (Qual _ n) = muName n + muQName (UnQual n) = muName n + muQName (Special HsUnitCon) = "()" + muQName (Special HsListCon) = "[]" + muQName (Special HsFunCon) = "->" + muQName (Special (HsTupleCon times)) = intercalate "" . replicate times $ "," + muQName (Special (HsCons)) = ":" + + 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) diff --git a/src/Language/Mulang/Parsers/Json.hs b/src/Language/Mulang/Parsers/Json.hs new file mode 100644 --- /dev/null +++ b/src/Language/Mulang/Parsers/Json.hs @@ -0,0 +1,46 @@ +module Language.Mulang.Parsers.Json (parseJson) where + +import Language.Mulang + +import Data.Aeson + +import qualified Data.ByteString.Lazy.Char8 as LBS (pack) + +parseJson :: String -> Maybe Program +parseJson = decode . LBS.pack + +instance FromJSON Program +instance ToJSON Program + +instance FromJSON Declaration +instance ToJSON Declaration + +instance FromJSON Equation +instance ToJSON Equation + +instance FromJSON Rhs +instance ToJSON Rhs + +instance FromJSON GuardedRhs +instance ToJSON GuardedRhs + +instance FromJSON Expression +instance ToJSON Expression + +instance FromJSON Pattern +instance ToJSON Pattern + +instance FromJSON ComprehensionStatement +instance ToJSON ComprehensionStatement + +instance FromJSON Alternative +instance ToJSON Alternative + +instance FromJSON GuardedAlternatives +instance ToJSON GuardedAlternatives + +instance FromJSON GuardedAlternative +instance ToJSON GuardedAlternative + +instance FromJSON LiteralValue +instance ToJSON LiteralValue