diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for elm-syntax + +## Unreleased changes + +## 0.1.0.0 + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Olle Fredriksson (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Olle Fredriksson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +# elm-syntax + +A library for generating Elm syntax from Haskell in a scope-safe way. + +This library has two main parts: + +* It defines abstract syntax trees (ASTs) for Elm definitions, expressions, patterns, +and types, using the [bound library](http://hackage.haskell.org/package/bound) +for scope-safe local names. +* It defines pretty printers from the ASTs to syntactically correct Elm code. 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/elm-syntax.cabal b/elm-syntax.cabal new file mode 100644 --- /dev/null +++ b/elm-syntax.cabal @@ -0,0 +1,70 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 34568c7261308560b811a1542c2c24662f8b482af2a3f2ea92974bcd11646def + +name: elm-syntax +version: 0.1.0.0 +synopsis: Elm syntax and pretty-printing +description: Please see the README on GitHub at +category: Elm, Compiler, Language +homepage: https://github.com/folq/elm-syntax#readme +bug-reports: https://github.com/folq/elm-syntax/issues +author: Olle Fredriksson +maintainer: fredriksson.olle@gmail.com +copyright: 2019 Olle Fredriksson +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/folq/elm-syntax + +library + exposed-modules: + Language.Elm.Definition + Language.Elm.Expression + Language.Elm.Name + Language.Elm.Pattern + Language.Elm.Pretty + Language.Elm.Type + other-modules: + Paths_elm_syntax + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields + build-depends: + base >=4.7 && <5 + , bound >=2.0.0 + , deriving-compat >=0.5 + , prettyprinter >=1.2.1 + , protolude >=0.2.3 + , text >=1.2.0 + , unordered-containers >=0.2.8 + default-language: Haskell2010 + +test-suite elm-syntax-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_elm_syntax + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wtabs -funbox-strict-fields -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , bound >=2.0.0 + , deriving-compat >=0.5 + , elm-syntax + , 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 new file mode 100644 --- /dev/null +++ b/src/Language/Elm/Definition.hs @@ -0,0 +1,40 @@ +module Language.Elm.Definition where + +import Protolude hiding (Type) + +import Language.Elm.Expression (Expression) +import qualified Language.Elm.Expression as Expression +import qualified Language.Elm.Name as Name +import Language.Elm.Type (Type) +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) + deriving (Eq, Ord, Show) + +name :: Definition -> Name.Qualified +name (Constant n _ _) = n +name (Type n _) = n +name (Alias n _) = n + +foldMapGlobals + :: Monoid m + => (Name.Qualified -> m) + -> Definition + -> m +foldMapGlobals f def = + case def of + Constant qname type_ expr -> + f qname <> + Type.foldMapGlobals f type_ <> + Expression.foldMapGlobals f expr + + Type qname constrs -> + f qname <> + foldMap (foldMap (foldMap (Type.foldMapGlobals f))) constrs + + Alias qname type_ -> + f qname <> + Type.foldMapGlobals f type_ diff --git a/src/Language/Elm/Expression.hs b/src/Language/Elm/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/Expression.hs @@ -0,0 +1,149 @@ +{-# language DeriveAnyClass #-} +{-# language DeriveFoldable #-} +{-# language DeriveFunctor #-} +{-# language DeriveGeneric #-} +{-# language DeriveTraversable #-} +{-# language OverloadedStrings #-} +{-# language StandaloneDeriving #-} +{-# language TemplateHaskell #-} +module Language.Elm.Expression where + +import Protolude + +import Bound +import Data.Bifoldable +import Data.Eq.Deriving +import Data.Ord.Deriving +import Data.String +import Text.Show.Deriving + +import qualified Language.Elm.Name as Name +import Language.Elm.Pattern (Pattern) +import qualified Language.Elm.Pattern as Pattern + +data Expression v + = Var v + | Global Name.Qualified + | App (Expression v) (Expression v) + | Let (Expression v) (Scope () Expression v) + | Lam (Scope () Expression v) + | Record [(Name.Field, Expression v)] + | Proj Name.Field + | Case (Expression v) [(Pattern Int, Scope Int Expression v)] + | If (Expression v) (Expression v) (Expression v) + | List [Expression v] + | String !Text + | Int !Integer + | Float !Double + deriving (Functor, Foldable, Traversable) + +instance Applicative Expression where + pure = Var + (<*>) = 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] + If e e1 e2 >>= f = If (e >>= f) (e1 >>= f) (e2 >>= f) + List es >>= f = List ((>>= f) <$> es) + String s >>= _ = String s + Int n >>= _ = Int n + Float f >>= _ = Float f + +deriving instance Eq v => Eq (Expression v) +deriving instance Ord v => Ord (Expression v) +deriving instance Show v => Show (Expression v) + +deriveEq1 ''Expression +deriveOrd1 ''Expression +deriveShow1 ''Expression + +instance IsString (Expression v) where + fromString = Global . fromString + +apps :: Foldable f => Expression v -> f (Expression v) -> Expression v +apps = foldl App + +appsView :: Expression v -> (Expression v, [Expression v]) +appsView = go mempty + where + go args expr = + case expr of + App e1 e2 -> + go (e2 : args) e1 + + _ -> + (expr, args) + +(|>) :: Expression v -> Expression v -> Expression v +(|>) e1 e2 = apps "Basics.|>" [e1, e2] + +(<|) :: Expression v -> Expression v -> Expression v +(<|) e1 e2 = apps "Basics.<|" [e1, e2] + +(<<) :: Expression v -> Expression v -> Expression v +(<<) e1 e2 = apps "Basics.<<" [e1, e2] + +(>>) :: Expression v -> Expression v -> Expression v +(>>) e1 e2 = apps "Basics.>>" [e1, e2] + +(++) :: Expression v -> Expression v -> Expression v +(++) e1 e2 = apps "Basics.++" [e1, e2] + +tuple :: Expression v -> Expression v -> Expression v +tuple e1 e2 = apps "Basics.," [e1, e2] + +foldMapGlobals + :: Monoid m + => (Name.Qualified -> m) + -> Expression v + -> m +foldMapGlobals f expr = + case expr of + Var _ -> + mempty + + Global qname -> + f qname + + App e1 e2 -> + foldMapGlobals f e1 <> foldMapGlobals f e2 + + Let e s -> + foldMapGlobals f e <> foldMapGlobals f (Bound.fromScope s) + + Lam s -> + foldMapGlobals f (Bound.fromScope s) + + Record fields -> + foldMap (foldMap (foldMapGlobals f)) fields + + Proj _ -> + mempty + + Case e branches -> + foldMapGlobals f e <> + foldMap + (bifoldMap (Pattern.foldMapGlobals f) (foldMapGlobals f . Bound.fromScope)) + branches + + If e e1 e2 -> + foldMapGlobals f e <> foldMapGlobals f e1 <> foldMapGlobals f e2 + + List es -> + foldMap (foldMapGlobals f) es + + String _ -> + mempty + + Int _ -> + mempty + + Float _ -> + mempty diff --git a/src/Language/Elm/Name.hs b/src/Language/Elm/Name.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/Name.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module Language.Elm.Name where + +import Protolude + +import Data.String +import qualified Data.Text as Text + +type Module = [Text] + +newtype Local = Local Text + deriving stock (Eq, Ord, Show, Generic) + deriving newtype IsString + deriving anyclass (Hashable) + +data Qualified = Qualified Module Text + deriving (Eq, Ord, Show, Generic, Hashable) + +instance IsString Qualified where + fromString s = + case unsnoc $ Text.splitOn "." $ fromString s of + Nothing -> + panic "Empty name" + + Just ([], x) -> + panic $ "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) + +newtype Constructor = Constructor Text + deriving stock (Eq, Ord, Show, Generic) + deriving newtype IsString + deriving anyclass (Hashable) diff --git a/src/Language/Elm/Pattern.hs b/src/Language/Elm/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/Pattern.hs @@ -0,0 +1,51 @@ +{-# language DeriveFoldable #-} +{-# language DeriveFunctor #-} +{-# language DeriveTraversable #-} +{-# language NoImplicitPrelude #-} +{-# language OverloadedStrings #-} +module Language.Elm.Pattern where + +import Protolude + +import qualified Language.Elm.Name as Name + +data Pattern v + = Var v + | Wildcard + | Con Name.Qualified [Pattern v] + | List [Pattern v] + | String !Text + | Int !Integer + | Float !Double + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +foldMapGlobals + :: Monoid m + => (Name.Qualified -> m) + -> Pattern v + -> m +foldMapGlobals f pat = + case pat of + Var _ -> + mempty + + Wildcard -> + mempty + + Con c pats -> + f c <> foldMap (foldMapGlobals f) pats + + List pats -> + foldMap (foldMapGlobals f) pats + + String _ -> + mempty + + Int _ -> + mempty + + Float _ -> + mempty + +tuple :: Pattern v -> Pattern v -> Pattern v +tuple p1 p2 = Con "Basics.," [p1, p2] diff --git a/src/Language/Elm/Pretty.hs b/src/Language/Elm/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/Pretty.hs @@ -0,0 +1,665 @@ +{-# language NoImplicitPrelude #-} +{-# language OverloadedStrings #-} +{-# language ViewPatterns #-} +module Language.Elm.Pretty + ( + -- * Modules + modules + , module_ + -- * Environments + , Environment(..) + , emptyEnvironment + , extend + -- * Pretty-printing names + , local + , field + , constructor + , moduleName + , qualified + -- * Pretty-printing definitions + , definition + -- * Pretty-printing expressions + , expression + -- * Pretty-printing pattern + , pattern + -- * Pretty-printing types + , type_ + ) where + +import Protolude hiding (Type, local, list, moduleName) + +import qualified Bound +import qualified Bound.Var as Bound +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.String +import Data.Text.Prettyprint.Doc + +import Language.Elm.Definition (Definition) +import qualified Language.Elm.Definition as Definition +import Language.Elm.Expression (Expression) +import qualified Language.Elm.Expression as Expression +import qualified Language.Elm.Name as Name +import Language.Elm.Pattern (Pattern) +import qualified Language.Elm.Pattern as Pattern +import Language.Elm.Type (Type) +import qualified Language.Elm.Type as Type + +------------------------------------------------------------------------------- +-- * Modules + +-- | Group the given definitions by their defining module, and generate an Elm +-- module for each group. +modules :: [Definition] -> HashMap Name.Module (Doc ann) +modules defs = + let + defsByModule = + foldl' + (HashMap.unionWith (<>)) + mempty + [ HashMap.singleton m [def] + | def <- defs + , let + (Name.Qualified m _) = + Definition.name def + ] + in + HashMap.mapWithKey module_ defsByModule + +-- | Generate an Elm module containing the given definitions. +module_ :: Name.Module -> [Definition] -> Doc ann +module_ mname defs = + let + usedNames = + HashSet.fromList + [ Name.Local name + | Name.Qualified _ name <- Definition.name <$> defs + ] + + env = + (emptyEnvironment mname) + { freshLocals = filter (not . (`HashSet.member` usedNames)) $ freshLocals (emptyEnvironment mname) + } + + imports = + sort $ + HashSet.toList $ + flip HashSet.difference defaultImports $ + HashSet.filter (/= mname) $ + HashSet.map (\(Name.Qualified m _) -> m) $ + HashSet.filter (isNothing . defaultImport) $ + foldMap (Definition.foldMapGlobals HashSet.singleton) defs + in + "module" <+> moduleName mname <+> "exposing (..)" <> line <> line <> + mconcat ["import" <+> moduleName import_ <> line | import_ <- imports] <> line <> line <> + mconcat (intersperse (line <> line <> line) [definition env def | def <- defs]) + +defaultImports :: HashSet Name.Module +defaultImports = + HashSet.fromList + [ ["Basics"] + , ["List"] + , ["Maybe"] + , ["Result"] + , ["String"] + , ["Char"] + , ["Tuple"] + , ["Debug"] + , ["Platform"] + , ["Cmd"] + , ["Sub"] + ] + +------------------------------------------------------------------------------- +-- * Environments + +-- | A pretty-printing environment with local variables in @v@. +data Environment v = Environment + { locals :: v -> Name.Local + , freshLocals :: [Name.Local] + , currentModule :: Name.Module + } + +emptyEnvironment :: Name.Module -> Environment Void +emptyEnvironment m = Environment + { locals = absurd + , freshLocals = (fromString . pure <$> ['a'..'z']) ++ [fromString $ [x] <> show n | x <- ['a'..'z'], n <- [(0 :: Int)..]] + , currentModule = m + } + +extend :: Environment v -> (Environment (Bound.Var () v), Name.Local) +extend env = + case freshLocals env of + [] -> + panic "Language.Elm.Pretty no locals" + + fresh:freshLocals' -> + ( env + { locals = Bound.unvar (\() -> fresh) (locals env) + , freshLocals = freshLocals' + } + , fresh + ) + +extendPat :: Environment v -> Pattern Int -> Environment (Bound.Var Int v) +extendPat env pat = + let + occurrencesSet = + foldMap HashSet.singleton pat + + occurrences = + HashSet.toList occurrencesSet + + bindings = + HashMap.fromList $ + zip occurrences $ freshLocals env + + freshLocals' = + drop (length occurrences) $ freshLocals env + + lookupVar i = + case HashMap.lookup i bindings of + Nothing -> + panic "Unbound pattern variable" + + Just v -> + v + in + env + { locals = Bound.unvar lookupVar (locals env) + , freshLocals = freshLocals' + } + +------------------------------------------------------------------------------- +-- * Pretty-printing names + +local :: Name.Local -> Doc ann +local (Name.Local l) = + pretty l + +field :: Name.Field -> Doc ann +field (Name.Field f) = + pretty f + +constructor :: Name.Constructor -> Doc ann +constructor (Name.Constructor c) = + pretty c + +moduleName :: Name.Module -> Doc ann +moduleName ms = + mconcat (intersperse dot $ pretty <$> ms) + +qualified :: Environment v -> Name.Qualified -> Doc ann +qualified env name@(Name.Qualified ms l) = + case defaultImport name of + Nothing + | ms == currentModule env -> + pretty l + + | otherwise -> + case ms of + [] -> + pretty l + + _ -> + moduleName ms <> dot <> pretty l + + Just l' -> + local l' + +defaultImport :: Name.Qualified -> Maybe Name.Local +defaultImport qname = + case qname of + Name.Qualified ["Basics"] name -> + Just $ Name.Local name + + "Cmd.Cmd" -> + Just "Cmd" + + "List.List" -> + Just "List" + + "List.::" -> + Just "::" + + "Maybe.Maybe" -> + Just "Maybe" + + "Maybe.Nothing" -> + Just "Nothing" + + "Maybe.Just" -> + Just "Just" + + "Result.Result" -> + Just "Result" + + "Result.Ok" -> + Just "Ok" + + "Result.Err" -> + Just "Err" + + "String.String" -> + Just "String" + + "Char.Char" -> + Just "Char" + + _ -> Nothing + +fixity :: Name.Qualified -> Maybe (Int, Int, Int) +fixity qname = + case qname of + "Basics.>>" -> + leftAssoc 9 + + "Basics.<<" -> + rightAssoc 9 + + "Basics.^" -> + rightAssoc 8 + + "Basics.*" -> + leftAssoc 7 + + "Basics./" -> + leftAssoc 7 + + "Basics.//" -> + leftAssoc 7 + + "Basics.%" -> + leftAssoc 7 + + "Basics.+" -> + leftAssoc 6 + + "Basics.-" -> + leftAssoc 6 + + "Parser.|=" -> + leftAssoc 5 + + Name.Qualified ["Parser"] "|." -> + leftAssoc 6 + + "Basics.++" -> + rightAssoc 5 + + "Basics.++" -> + rightAssoc 5 + + "List.::" -> + rightAssoc 5 + + "Basics.==" -> + noneAssoc 4 + + "Basics./=" -> + noneAssoc 4 + + "Basics.<" -> + noneAssoc 4 + + "Basics.>" -> + noneAssoc 4 + + "Basics.<=" -> + noneAssoc 4 + + "Basics.>=" -> + noneAssoc 4 + + "Basics.&&" -> + rightAssoc 3 + + "Basics.||" -> + leftAssoc 3 + + "Basics.|>" -> + leftAssoc 0 + + "Basics.<|" -> + rightAssoc 0 + + "Basics.," -> + Just (0, -1, 0) + + _ -> + Nothing + + where + leftAssoc n = + Just (n, n, n + 1) + + rightAssoc n = + Just (n, n, n + 1) + + noneAssoc n = + Just (n + 1, n, n + 1) + +twoLineOperator :: Name.Qualified -> Bool +twoLineOperator qname = + case qname of + "Basics.>>" -> + True + + "Basics.<<" -> + True + + "Basics.|>" -> + True + + "Basics.<|" -> + True + + _ -> + False + +------------------------------------------------------------------------------- +-- * Definitions + +definition :: Environment Void -> Definition -> Doc ann +definition env def = + case def of + Definition.Constant (Name.Qualified _ name) t e -> + let + (names, body) = lambdas env e + in + pretty name <+> ":" <+> nest 4 (type_ env 0 t) <> line <> + (case names of + [] -> + pretty name <+> "=" + + _ -> + pretty name <+> hsep (local <$> names) <+> "=") <> + line <> indent 4 body + + Definition.Type (Name.Qualified _ name) constrs -> + "type" <+> pretty name <> line <> + indent 4 ("=" <+> + mconcat + (intersperse (line <> "| ") + [constructor c <+> hsep (type_ env (appPrec + 1) <$> ts) | (c, ts) <- constrs])) + + Definition.Alias (Name.Qualified _ name) t -> + "type alias" <+> pretty name <+> "=" <> line <> + indent 4 (type_ env 0 t) + +------------------------------------------------------------------------------- +-- * Expressions + +expression :: Environment v -> Int -> Expression v -> Doc ann +expression env prec expr = + case expr of + Expression.Var var -> + local $ locals env var + + (Expression.appsView -> (Expression.Proj f, arg:args)) -> + atomApps (expression env) prec (expression env projPrec arg <> dot <> field f) args + + (Expression.appsView -> (Expression.Global qname@(Name.Qualified _ name), args)) -> + case fixity qname of + Nothing -> + atomApps (expression env) prec (qualified env qname) args + + Just (leftPrec, opPrec, rightPrec) -> + case args of + [arg1, arg2] -> + parensWhen (prec > opPrec) $ + expression env leftPrec arg1 <+> pretty name <> + (if twoLineOperator qname then line else space) <> + expression env rightPrec arg2 + + arg1:arg2:args' -> + apps (expression env) prec (Expression.apps (Expression.Global qname) [arg1, arg2]) args' + + _ -> + atomApps (expression env) prec (parens $ pretty name) args + + (Expression.appsView -> (fun, args@(_:_))) -> + apps (expression env) prec fun args + + Expression.Global _ -> + panic "Language.Elm.Pretty expression Global" + + Expression.App {} -> + panic "Language.Elm.Pretty expression App" + + Expression.Let {} -> + parensWhen (prec > letPrec) $ + let + (bindings, body) = + lets env expr + in + "let" + <> line <> indent 4 (mconcat $ intersperse (line <> line) bindings) + <> line <> "in" + <> line <> body + + Expression.Lam {} -> + parensWhen (prec > lamPrec) $ + let + (names, body) = + lambdas env expr + in + "\\" <> hsep (local <$> names) <+> "->" <+> body + + Expression.Record fields -> + encloseSep "{ " " }" ", " + [ field f <+> "=" <+> expression env 0 expr' + | (f, expr') <- fields + ] + + Expression.Proj f -> + "." <> field f + + Expression.Case expr' branches -> + parensWhen (prec > casePrec) $ + "case" <+> expression env 0 expr' <+> "of" <> line <> + indent 4 + ( + mconcat $ + intersperse (line <> line) $ + [ pattern env' 0 pat <+> "->" <> line <> indent 4 (expression env' 0 (Bound.fromScope scope)) + | (pat, scope) <- branches + , let + env' = + extendPat env pat + ] + ) + + Expression.If expr' true false -> + parensWhen (prec > ifPrec) $ + "if" <+> expression env 0 expr' <+> "then" <> line <> + indent 4 (expression env 0 true) <> line <> + line <> + "else" <> line <> + indent 4 (expression env 0 false) + + Expression.List exprs -> + list $ expression env 0 <$> exprs + + Expression.String s -> + "\"" <> pretty s <> "\"" + + Expression.Int i -> + pretty i + + Expression.Float f -> + pretty f + +lets :: Environment v -> Expression v -> ([Doc ann], Doc ann) +lets env expr = + case expr of + Expression.Let expr' scope -> + let + (env', name) = + extend env + + (bindings, body) = + lets env' (Bound.fromScope scope) + + binding = + local name <+> "=" + <> line <> indent 4 (expression env 0 expr') + + in + (binding : bindings , body) + + _ -> + ([], expression env letPrec expr) + +lambdas :: Environment v -> Expression v -> ([Name.Local], Doc ann) +lambdas env expr = + case expr of + Expression.Lam scope -> + let + (env', name) = + extend env + + (names, body) = + lambdas env' (Bound.fromScope scope) + in + (name : names, body) + + _ -> + ([], expression env lamPrec expr) + +------------------------------------------------------------------------------- +-- * Patterns + +pattern :: Environment (Bound.Var Int v) -> Int -> Pattern Int -> Doc ann +pattern env prec pat = + case pat of + Pattern.Var var -> + local $ locals env (Bound.B var) + + Pattern.Wildcard -> + "_" + + Pattern.Con con [] -> + qualified env con + + Pattern.Con con@(Name.Qualified _ name) pats -> + case fixity con of + Nothing -> + parensWhen (prec > appPrec) $ + qualified env con <+> hsep (pattern env (appPrec + 1) <$> pats) + + Just (leftPrec, opPrec, rightPrec) -> + case pats of + [pat1, pat2] -> + parensWhen (prec > opPrec) $ + pattern env leftPrec pat1 <+> pretty name <> + (if twoLineOperator con then line else space) <> + pattern env rightPrec pat2 + + pat1:pat2:pats' -> + apps (pattern env) prec (Pattern.Con con [pat1, pat2]) pats' + + _ -> + parensWhen (prec > appPrec) $ + qualified env con <+> hsep (pattern env (appPrec + 1) <$> pats) + + Pattern.List pats -> + list $ pattern env 0 <$> pats + + Pattern.String s -> + "\"" <> pretty s <> "\"" + + Pattern.Int i -> + pretty i + + Pattern.Float f -> + pretty f + +------------------------------------------------------------------------------- +-- * Types + +type_ :: Environment v -> Int -> Type v -> Doc ann +type_ env prec t = + case t of + Type.Var var -> + local $ locals env var + + (Type.appsView -> (Type.Global qname@(Name.Qualified _ name), args)) -> + case fixity qname of + Nothing -> + atomApps (type_ env) prec (qualified env qname) args + + Just (leftPrec, opPrec, rightPrec) -> + case args of + [arg1, arg2] -> + parensWhen (prec > opPrec) $ + type_ env leftPrec arg1 <+> pretty name <> + (if twoLineOperator qname then line else space) <> + type_ env rightPrec arg2 + + arg1:arg2:args' -> + apps (type_ env) prec (Type.apps (Type.Global qname) [arg1, arg2]) args' + + _ -> + atomApps (type_ env) prec (parens $ pretty name) args + + (Type.appsView -> (fun, args@(_:_))) -> + apps (type_ env) prec fun args + + Type.Global _ -> + panic "Language.Elm.Pretty type_ Global" + + Type.App {} -> + panic "Language.Elm.Pretty type_ App" + + Type.Fun t1 t2 -> + parensWhen (prec > funPrec) $ + type_ env (funPrec + 1) t1 <+> "->" <+> type_ env funPrec t2 + + Type.Record fields -> + encloseSep "{ " " }" ", " + [ field f <+> ":" <+> type_ env 0 type' + | (f, type') <- fields + ] + +------------------------------------------------------------------------------- +-- Utils + +apps :: (Int -> a -> Doc ann) -> Int -> a -> [a] -> Doc ann +apps f prec fun args = + case args of + [] -> + f prec fun + + _ -> + parensWhen (prec > appPrec) $ + f appPrec fun <+> hsep (f (appPrec + 1) <$> args) + +atomApps :: (Int -> a -> Doc ann) -> Int -> Doc ann -> [a] -> Doc ann +atomApps f prec fun args = + case args of + [] -> + fun + + _ -> + parensWhen (prec > appPrec) $ + fun <+> hsep (f (appPrec + 1) <$> args) + +parensWhen :: Bool -> Doc ann -> Doc ann +parensWhen b = + if b then + parens + + else + identity + +appPrec, letPrec, lamPrec, casePrec, ifPrec, funPrec, projPrec :: Int +appPrec = 10 +letPrec = 0 +lamPrec = 0 +casePrec = 0 +ifPrec = 0 +funPrec = 0 +projPrec = 11 diff --git a/src/Language/Elm/Type.hs b/src/Language/Elm/Type.hs new file mode 100644 --- /dev/null +++ b/src/Language/Elm/Type.hs @@ -0,0 +1,76 @@ +{-# language DeriveFoldable #-} +{-# language DeriveFunctor #-} +{-# language DeriveTraversable #-} +{-# language OverloadedStrings #-} +module Language.Elm.Type where + +import Protolude hiding (Type) + +import Data.String + +import qualified Language.Elm.Name as Name + +data Type v + = Var v + | Global Name.Qualified + | App (Type v) (Type v) + | Fun (Type v) (Type v) + | Record [(Name.Field, Type v)] + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +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] + +instance IsString (Type v) where + fromString = Global . fromString + +apps :: Type v -> [Type v] -> Type v +apps = foldl' App + +appsView :: Type v -> (Type v, [Type v]) +appsView = go mempty + where + go args typ = + case typ of + App t1 t2 -> + go (t2 : args) t1 + + _ -> + (typ, args) + +funs :: [Type v] -> Type v -> Type v +funs args ret = + foldr Fun ret args + +tuple :: Type v -> Type v -> Type v +tuple t1 t2 = apps "Basics.," [t1, t2] + +foldMapGlobals + :: Monoid m + => (Name.Qualified -> m) + -> Type v + -> m +foldMapGlobals f type_ = + case type_ of + Var _ -> + mempty + + Global qname -> + f qname + + App t1 t2 -> + foldMapGlobals f t1 <> foldMapGlobals f t2 + + Fun t1 t2 -> + foldMapGlobals f t1 <> foldMapGlobals f t2 + + Record fields -> + foldMap (foldMap (foldMapGlobals f)) fields diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"