elm-syntax (empty) → 0.1.0.0
raw patch · 12 files changed
+1146/−0 lines, 12 filesdep +basedep +bounddep +deriving-compatsetup-changed
Dependencies added: base, bound, deriving-compat, elm-syntax, prettyprinter, protolude, text, unordered-containers
Files
- CHANGELOG.md +7/−0
- LICENSE +30/−0
- README.md +10/−0
- Setup.hs +2/−0
- elm-syntax.cabal +70/−0
- src/Language/Elm/Definition.hs +40/−0
- src/Language/Elm/Expression.hs +149/−0
- src/Language/Elm/Name.hs +44/−0
- src/Language/Elm/Pattern.hs +51/−0
- src/Language/Elm/Pretty.hs +665/−0
- src/Language/Elm/Type.hs +76/−0
- test/Spec.hs +2/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog for elm-syntax++## Unreleased changes++## 0.1.0.0++- Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elm-syntax.cabal view
@@ -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 <https://github.com/folq/elm-syntax#readme>+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
+ src/Language/Elm/Definition.hs view
@@ -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_
+ src/Language/Elm/Expression.hs view
@@ -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
+ src/Language/Elm/Name.hs view
@@ -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)
+ src/Language/Elm/Pattern.hs view
@@ -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]
+ src/Language/Elm/Pretty.hs view
@@ -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
+ src/Language/Elm/Type.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"