diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,17 @@ ## Unreleased changes +## 0.3.0.0 + +- Add support for parameterised types +- Handle Basics.() in isConstructor check +- Simplify case-of-case expressions + +## 0.2.0.0 + +- Add simplification module with some useful optimisations + + ## 0.1.0.0 - Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# elm-syntax [![Hackage](https://img.shields.io/hackage/v/elm-syntax.svg)](https://hackage.haskell.org/package/elm-syntax) +# elm-syntax [![Build Status](https://travis-ci.com/folq/elm-syntax.svg?branch=master)](https://travis-ci.com/folq/elm-syntax) [![Hackage](https://img.shields.io/hackage/v/elm-syntax.svg)](https://hackage.haskell.org/package/elm-syntax) A library for generating Elm syntax from Haskell in a scope-safe way. diff --git a/elm-syntax.cabal b/elm-syntax.cabal --- a/elm-syntax.cabal +++ b/elm-syntax.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 3062daa5e99746ac78a65379398eeb1af44d09e10354ae4f3aaae3c1885431ef +-- hash: 7a5a97356a0303c135c29af83618eccb2a2d5844234020ab4cd4f38ee561609d name: elm-syntax -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Elm syntax and pretty-printing description: Please see the README on GitHub at category: Elm, Compiler, Language @@ -18,6 +18,7 @@ copyright: 2019 Olle Fredriksson license: BSD3 license-file: LICENSE +tested-with: GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.3 build-type: Simple extra-source-files: README.md @@ -44,9 +45,9 @@ build-depends: base >=4.7 && <5 , bound >=2.0.0 - , deriving-compat >=0.5 + , deriving-compat >=0.5.0 + , hashable >=1.2.5 , prettyprinter >=1.2.1 - , protolude >=0.2.3 , text >=1.2.0 , unordered-containers >=0.2.8 default-language: Haskell2010 @@ -62,10 +63,10 @@ build-depends: base >=4.7 && <5 , bound >=2.0.0 - , deriving-compat >=0.5 + , deriving-compat >=0.5.0 , elm-syntax + , hashable >=1.2.5 , prettyprinter >=1.2.1 - , protolude >=0.2.3 , text >=1.2.0 , unordered-containers >=0.2.8 default-language: Haskell2010 diff --git a/src/Language/Elm/Definition.hs b/src/Language/Elm/Definition.hs --- a/src/Language/Elm/Definition.hs +++ b/src/Language/Elm/Definition.hs @@ -1,7 +1,10 @@ module Language.Elm.Definition where -import Protolude hiding (Type) +import Data.Void +import Bound (Scope) +import qualified Bound + import Language.Elm.Expression (Expression) import qualified Language.Elm.Expression as Expression import qualified Language.Elm.Name as Name @@ -9,15 +12,15 @@ import qualified Language.Elm.Type as Type data Definition - = Constant !Name.Qualified (Type Void) (Expression Void) - | Type !Name.Qualified [(Name.Constructor, [Type Void])] - | Alias !Name.Qualified (Type Void) + = Constant !Name.Qualified !Int (Scope Int Type Void) (Expression Void) + | Type !Name.Qualified !Int [(Name.Constructor, [Scope Int Type Void])] + | Alias !Name.Qualified !Int (Scope Int Type Void) deriving (Eq, Ord, Show) name :: Definition -> Name.Qualified -name (Constant n _ _) = n -name (Type n _) = n -name (Alias n _) = n +name (Constant n _ _ _) = n +name (Type n _ _) = n +name (Alias n _ _) = n foldMapGlobals :: Monoid m @@ -26,15 +29,15 @@ -> m foldMapGlobals f def = case def of - Constant qname type_ expr -> + Constant qname _ type_ expr -> f qname <> - Type.foldMapGlobals f type_ <> + Type.foldMapGlobals f (Bound.fromScope type_) <> Expression.foldMapGlobals f expr - Type qname constrs -> + Type qname _ constrs -> f qname <> - foldMap (foldMap (foldMap (Type.foldMapGlobals f))) constrs + foldMap (foldMap (foldMap (Type.foldMapGlobals f . Bound.fromScope))) constrs - Alias qname type_ -> + Alias qname _ type_ -> f qname <> - Type.foldMapGlobals f type_ + Type.foldMapGlobals f (Bound.fromScope type_) diff --git a/src/Language/Elm/Expression.hs b/src/Language/Elm/Expression.hs --- a/src/Language/Elm/Expression.hs +++ b/src/Language/Elm/Expression.hs @@ -4,18 +4,20 @@ {-# language DeriveGeneric #-} {-# language DeriveTraversable #-} {-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} {-# language StandaloneDeriving #-} {-# language TemplateHaskell #-} module Language.Elm.Expression where -import Protolude - import Bound import Bound.Var (unvar) +import Control.Monad import Data.Bifoldable +import Data.Bifunctor import Data.Eq.Deriving import Data.Ord.Deriving import Data.String +import Data.Text (Text) import Text.Show.Deriving import qualified Language.Elm.Name as Name @@ -42,19 +44,56 @@ (<*>) = ap instance Monad Expression where - Var v >>= f = f v - Global g >>= _ = Global g - App e1 e2 >>= f = App (e1 >>= f) (e2 >>= f) - Let e s >>= f = Let (e >>= f) (s >>>= f) - Lam s >>= f = Lam (s >>>= f) - Record fs >>= f = Record [(fname, e >>= f) | (fname, e) <- fs] - Proj f >>= _ = Proj f - Case e brs >>= f = Case (e >>= f) [(pat, s >>>= f) | (pat, s) <- brs] - List es >>= f = List ((>>= f) <$> es) - String s >>= _ = String s - Int n >>= _ = Int n - Float f >>= _ = Float f + (>>=) = + flip $ bind Global +bind :: forall v v'. (Name.Qualified -> Expression v') -> (v -> Expression v') -> Expression v -> Expression v' +bind global var expression = + case expression of + Var v -> + var v + + Global g -> + global g + + App t1 t2 -> + App (bind global var t1) (bind global var t2) + + Let e s -> + Let (bind global var e) (bindScope s) + + Lam s -> + Lam (bindScope s) + + Record fields -> + Record $ second (bind global var) <$> fields + + Proj fname -> + Proj fname + + Case scrutinee branches -> + Case + (bind global var scrutinee) + (second bindScope <$> branches) + + List es -> + List $ bind global var <$> es + + String s -> + String s + + Int i -> + Int i + + Float f -> + Float f + where + bindScope :: Scope b Expression v -> Scope b Expression v' + bindScope = + toScope . + bind (fmap F . global) (unvar (pure . B) (fmap F . var)) . + fromScope + deriving instance Eq v => Eq (Expression v) deriving instance Ord v => Ord (Expression v) deriving instance Show v => Show (Expression v) @@ -107,7 +146,7 @@ lets :: Eq b => [(b, Expression v)] -> Scope b Expression v -> Expression v lets = - go (panic "Language.Elm.Expression.lets unbound var") identity + go (error "Language.Elm.Expression.lets unbound var") id where go :: Eq b => (b -> v') -> (v -> v') -> [(b, Expression v)] -> Scope b Expression v -> Expression v' go boundVar freeVar bindings scope = @@ -155,7 +194,7 @@ Case e branches -> foldMapGlobals f e <> foldMap - (bifoldMap (Pattern.foldMapGlobals f) (foldMapGlobals f . Bound.fromScope)) + (bifoldMap (Pattern.foldMapGlobals f) (foldMapGlobals f .Bound.fromScope)) branches List es -> diff --git a/src/Language/Elm/Name.hs b/src/Language/Elm/Name.hs --- a/src/Language/Elm/Name.hs +++ b/src/Language/Elm/Name.hs @@ -1,28 +1,40 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language OverloadedStrings #-} +{-# language ViewPatterns #-} module Language.Elm.Name where -import Protolude - -import Data.String +import Data.Bifunctor import qualified Data.Char as Char +import Data.Hashable +import Data.String +import Data.Text (Text) import qualified Data.Text as Text +import GHC.Generics (Generic) type Module = [Text] newtype Local = Local Text deriving stock (Eq, Ord, Show, Generic) - deriving newtype IsString + deriving newtype (IsString) deriving anyclass (Hashable) data Qualified = Qualified Module Text - deriving (Eq, Ord, Show, Generic, Hashable) + deriving (Eq, Ord, Show, Generic) + deriving anyclass (Hashable) +newtype Field = Field Text + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString) + deriving anyclass (Hashable) + +newtype Constructor = Constructor Text + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (IsString) + deriving anyclass (Hashable) + isConstructor :: Qualified -> Bool isConstructor name = case name of @@ -32,6 +44,9 @@ "Basics.," -> True + "Basics.()" -> + True + Qualified _ (Text.uncons -> Just (firstChar, _)) -> Char.isUpper firstChar @@ -42,20 +57,18 @@ fromString s = case unsnoc $ Text.splitOn "." $ fromString s of Nothing -> - panic "Empty name" + error "Empty name" Just ([], x) -> - panic $ "Unqualified name " <> show x + error $ "Unqualified name " <> show x Just (xs, x) -> Qualified xs x - -newtype Field = Field Text - deriving stock (Eq, Ord, Show, Generic) - deriving newtype IsString - deriving anyclass (Hashable) + where + unsnoc :: [a] -> Maybe ([a], a) + unsnoc [] = Nothing + unsnoc (a:as) = Just $ go a as -newtype Constructor = Constructor Text - deriving stock (Eq, Ord, Show, Generic) - deriving newtype IsString - deriving anyclass (Hashable) + go :: a -> [a] -> ([a], a) + go a [] = ([], a) + go a (a':as) = first (a:) $ go a' as diff --git a/src/Language/Elm/Pattern.hs b/src/Language/Elm/Pattern.hs --- a/src/Language/Elm/Pattern.hs +++ b/src/Language/Elm/Pattern.hs @@ -1,11 +1,10 @@ {-# language DeriveFoldable #-} {-# language DeriveFunctor #-} {-# language DeriveTraversable #-} -{-# language NoImplicitPrelude #-} {-# language OverloadedStrings #-} module Language.Elm.Pattern where -import Protolude +import Data.Text (Text) import qualified Language.Elm.Name as Name diff --git a/src/Language/Elm/Pretty.hs b/src/Language/Elm/Pretty.hs --- a/src/Language/Elm/Pretty.hs +++ b/src/Language/Elm/Pretty.hs @@ -1,4 +1,3 @@ -{-# language NoImplicitPrelude #-} {-# language OverloadedStrings #-} {-# language ViewPatterns #-} module Language.Elm.Pretty @@ -26,16 +25,18 @@ , type_ ) where -import Protolude hiding (Type, local, list, moduleName) - import qualified Bound import qualified Bound.Var as Bound +import Data.Foldable import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet +import Data.List (sort, intersperse) +import Data.Maybe (isNothing) import Data.String import Data.Text.Prettyprint.Doc +import Data.Void import Language.Elm.Definition (Definition) import qualified Language.Elm.Definition as Definition @@ -133,7 +134,7 @@ extend env = case freshLocals env of [] -> - panic "Language.Elm.Pretty no locals" + error "Language.Elm.Pretty no locals" fresh:freshLocals' -> ( env @@ -151,7 +152,12 @@ occurrences = HashSet.toList occurrencesSet + in + extendMany env occurrences +extendMany :: Environment v -> [Int] -> Environment (Bound.Var Int v) +extendMany env occurrences = + let bindings = HashMap.fromList $ zip occurrences $ freshLocals env @@ -162,7 +168,7 @@ lookupVar i = case HashMap.lookup i bindings of Nothing -> - panic "Unbound pattern variable" + error "Language.Elm.Pretty unbound pattern variable" Just v -> v @@ -365,11 +371,18 @@ definition :: Environment Void -> Definition -> Doc ann definition env def = case def of - Definition.Constant (Name.Qualified _ name) t e -> + Definition.Constant (Name.Qualified _ name) numTypeParams t e -> let - (names, body) = lambdas env e + typeParams = + [0..numTypeParams - 1] + + typeEnv = + extendMany env typeParams + + (names, body) = + lambdas env e in - pretty name <+> ":" <+> nest 4 (type_ env 0 t) <> line <> + pretty name <+> ":" <+> nest 4 (type_ typeEnv 0 $ Bound.fromScope t) <> line <> (case names of [] -> pretty name <+> "=" @@ -378,17 +391,31 @@ pretty name <+> hsep (local <$> names) <+> "=") <> line <> indent 4 body - Definition.Type (Name.Qualified _ name) constrs -> - "type" <+> pretty name <> line <> + Definition.Type (Name.Qualified _ name) numParams constrs -> + let + params = + [0..numParams - 1] + + env' = + extendMany env params + in + "type" <+> pretty name <+> hsep (local . locals env' . Bound.B <$> params) <> line <> indent 4 ("=" <+> mconcat (intersperse (line <> "| ") - [constructor c <+> hsep (type_ env (appPrec + 1) <$> ts) | (c, ts) <- constrs])) + [constructor c <+> hsep (type_ env' (appPrec + 1) . Bound.fromScope <$> ts) | (c, ts) <- constrs])) - Definition.Alias (Name.Qualified _ name) t -> - "type alias" <+> pretty name <+> "=" <> line <> - indent 4 (type_ env 0 t) + Definition.Alias (Name.Qualified _ name) numParams t -> + let + params = + [0..numParams - 1] + env' = + extendMany env params + in + "type alias" <+> pretty name <+> hsep (local . locals env' . Bound.B <$> params) <+> "=" <> line <> + indent 4 (type_ env' 0 $ Bound.fromScope t) + ------------------------------------------------------------------------------- -- * Expressions @@ -424,10 +451,10 @@ apps (expression env) prec fun args Expression.Global _ -> - panic "Language.Elm.Pretty expression Global" + error "Language.Elm.Pretty expression Global" Expression.App {} -> - panic "Language.Elm.Pretty expression App" + error "Language.Elm.Pretty expression App" Expression.Let {} -> parensWhen (prec > letPrec) $ @@ -612,10 +639,10 @@ apps (type_ env) prec fun args Type.Global _ -> - panic "Language.Elm.Pretty type_ Global" + error "Language.Elm.Pretty type_ Global" Type.App {} -> - panic "Language.Elm.Pretty type_ App" + error "Language.Elm.Pretty type_ App" Type.Fun t1 t2 -> parensWhen (prec > funPrec) $ @@ -656,7 +683,7 @@ parens else - identity + id appPrec, letPrec, lamPrec, casePrec, ifPrec, funPrec, projPrec :: Int appPrec = 10 diff --git a/src/Language/Elm/Simplification.hs b/src/Language/Elm/Simplification.hs --- a/src/Language/Elm/Simplification.hs +++ b/src/Language/Elm/Simplification.hs @@ -8,6 +8,7 @@ import Bound import qualified Bound.Scope as Scope import Bound.Var (unvar) +import Data.Bifunctor import Data.Foldable (fold) import Data.Text (Text) import qualified Data.Text as Text @@ -27,8 +28,8 @@ -> Definition simplifyDefinition def = case def of - Definition.Constant name type_ expr -> - Definition.Constant name type_ $ simplifyExpression expr + Definition.Constant name numTypeParams type_ expr -> + Definition.Constant name numTypeParams type_ $ simplifyExpression expr Definition.Type {} -> def @@ -50,8 +51,8 @@ -- * @x :: [y, z, ...] = [x, y, z, ...]@ -- * Calls to @String.join@, @String.concat@, @List.concat@, and @++@ with -- known arguments are simplified. For example, --- -- @String.join "/" [Config.api, "endpoint"] = Config.api ++ "/endpoint"@ +-- * @(\x. e x) = e@ -- * Inline @x@ in @e'@ in -- @ -- let x = e in e' @@ -67,6 +68,7 @@ -- @ -- is simplified to @let xs = es in branch@ provided that @e@ matches none of -- @prefixBranches@ and that it matches @pat@. +-- * case-of-case -- simplifyExpression :: Expression v @@ -171,9 +173,21 @@ in case findMatchingBranch scrutinee' branches of Nothing -> - Expression.apps - (Expression.Case scrutinee' $ fmap simplifyScope <$> branches) - args + case scrutinee' of + Expression.Case innerScrutinee innerBranches -> + simplifyApplication + (Expression.Case + innerScrutinee + [ (pat, toScope $ Expression.Case (fromScope branch) (second (fmap F) <$> branches)) + | (pat, branch) <- innerBranches + ] + ) + args + + _ -> + Expression.apps + (Expression.Case scrutinee' $ fmap simplifyScope <$> branches) + args Just expr' -> simplifyApplication expr' args diff --git a/src/Language/Elm/Type.hs b/src/Language/Elm/Type.hs --- a/src/Language/Elm/Type.hs +++ b/src/Language/Elm/Type.hs @@ -2,11 +2,16 @@ {-# language DeriveFunctor #-} {-# language DeriveTraversable #-} {-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} module Language.Elm.Type where -import Protolude hiding (Type) - +import Control.Monad +import Data.Bifunctor +import Data.Eq.Deriving (deriveEq1) +import Data.Foldable +import Data.Ord.Deriving (deriveOrd1) import Data.String +import Text.Show.Deriving (deriveShow1) import qualified Language.Elm.Name as Name @@ -18,16 +23,35 @@ | Record [(Name.Field, Type v)] deriving (Eq, Ord, Show, Functor, Foldable, Traversable) +deriveEq1 ''Type +deriveOrd1 ''Type +deriveShow1 ''Type + instance Applicative Type where pure = Var (<*>) = ap instance Monad Type where - Var v >>= f = f v - Global g >>= _ = Global g - App t1 t2 >>= f = App (t1 >>= f) (t2 >>= f) - Fun t1 t2 >>= f = Fun (t1 >>= f) (t2 >>= f) - Record fields >>= f = Record [(n, t >>= f) | (n, t) <- fields] + (>>=) = + flip $ bind Global + +bind :: (Name.Qualified -> Type v') -> (v -> Type v') -> Type v -> Type v' +bind global var type_ = + case type_ of + Var v -> + var v + + Global g -> + global g + + App t1 t2 -> + App (bind global var t1) (bind global var t2) + + Fun t1 t2 -> + Fun (bind global var t1) (bind global var t2) + + Record fields -> + Record $ second (bind global var) <$> fields instance IsString (Type v) where fromString = Global . fromString