Add support for parameterised types

Author: ollef

CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## Unreleased changes
 
+- Add support for parameterised types
 - Handle Basics.() in isConstructor check
 - Simplify case-of-case expressions
 

elm-syntax.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0ef776b3daae1808ec6d9199f2bba0aa2018977a5ba9d2f847c6940ecbcf85aa
+-- hash: 4852b94fa3c78222b53566d23352534c8fab264e301bc13f0c11d479c70ec497
 
 name:           elm-syntax
 version:        0.2.0.0
@@ -45,7 +45,7 @@ library
   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
     , text >=1.2.0
@@ -63,7 +63,7 @@ test-suite elm-syntax-test
   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

package.yaml

@@ -28,6 +28,7 @@ dependencies:
 - prettyprinter >= 1.2.1
 - text >= 1.2.0
 - unordered-containers >= 0.2.8
+- deriving-compat >= 0.5.0
 
 ghc-options:
   - -Wall

src/Language/Elm/Definition.hs

@@ -2,22 +2,25 @@ module Language.Elm.Definition where
 
 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
 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)
+  = 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 @@ foldMapGlobals
   -> 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_)

src/Language/Elm/Expression.hs

@@ -4,13 +4,16 @@
 {-# language DeriveGeneric #-}
 {-# language DeriveTraversable #-}
 {-# language OverloadedStrings #-}
+{-# language ScopedTypeVariables #-}
 {-# language StandaloneDeriving #-}
 {-# language TemplateHaskell #-}
 module Language.Elm.Expression where
 
 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
@@ -41,18 +44,55 @@ instance Applicative Expression where
   (<*>) = 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)
@@ -154,7 +194,7 @@ foldMapGlobals f expr =
     Case e branches ->
       foldMapGlobals f e <>
       foldMap
-        (\(pat, scope) -> Pattern.foldMapGlobals f pat <> foldMapGlobals f (Bound.fromScope scope))
+        (bifoldMap (Pattern.foldMapGlobals f) (foldMapGlobals f .Bound.fromScope))
         branches
 
     List es ->

src/Language/Elm/Pretty.hs

@@ -152,7 +152,12 @@ extendPat env pat =
 
     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
@@ -163,7 +168,7 @@ extendPat env pat =
     lookupVar i =
       case HashMap.lookup i bindings of
         Nothing ->
-          error "Unbound pattern variable"
+          error "Language.Elm.Pretty unbound pattern variable"
 
         Just v ->
           v
@@ -366,11 +371,18 @@ twoLineOperator qname =
 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 <+> "="
@@ -379,16 +391,30 @@ definition env def =
           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

src/Language/Elm/Simplification.hs

@@ -28,8 +28,8 @@ simplifyDefinition
   -> 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

src/Language/Elm/Type.hs

@@ -2,11 +2,16 @@
 {-# language DeriveFunctor #-}
 {-# language DeriveTraversable #-}
 {-# language OverloadedStrings #-}
+{-# language TemplateHaskell #-}
 module Language.Elm.Type where
 
 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 @@ data Type v
   | 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