packages feed

purescript 0.3.1 → 0.3.2

raw patch · 11 files changed

+228/−85 lines, 11 files

Files

purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.3.1+version: 0.3.2 cabal-version: >=1.8 build-type: Simple license: MIT@@ -11,8 +11,8 @@ description: A small compile-to-JS language with extensible records and type-safe blocks category: Language author: Phil Freeman <paf31@cantab.net>-data-dir: "" data-files: libraries/prelude/prelude.purs+data-dir: ""  library     build-depends: base >=4 && <5, cmdtheline -any, containers -any,@@ -29,6 +29,7 @@                      Language.PureScript.Values                      Language.PureScript.Scope                      Language.PureScript.Sugar+                     Language.PureScript.ModuleDependencies                      Language.PureScript.Sugar.CaseDeclarations                      Language.PureScript.Sugar.DoNotation                      Language.PureScript.Sugar.TypeDeclarations@@ -63,32 +64,32 @@     exposed: True     buildable: True     hs-source-dirs: src+    other-modules:  executable psc     build-depends: base >=4 && <5, cmdtheline -any, containers -any,                    directory -any, filepath -any, mtl -any, parsec -any,                    purescript -any, syb -any, transformers -any, utf8-string -any     main-is: Main.hs-    hs-source-dirs: psc     buildable: True+    hs-source-dirs: psc     other-modules:     ghc-options: -Wall -O2 -fno-warn-unused-do-bind  executable psci-    build-depends: base >=4 && <5, containers -any,-                   mtl -any, parsec -any, haskeline <= 0.7.1.1,-                   purescript -any, syb -any, transformers -any, utf8-string -any,-                   process -any+    build-depends: base >=4 && <5, containers -any, mtl -any,+                   parsec -any, haskeline <=0.7.1.1, purescript -any, syb -any,+                   transformers -any, utf8-string -any, process -any     main-is: Main.hs-    hs-source-dirs: psci     buildable: True+    hs-source-dirs: psci     other-modules:     ghc-options: -Wall -O2  test-suite tests-    build-depends: base >=4 && <5, containers -any,-                   directory -any, filepath -any, mtl -any, parsec -any,-                   purescript -any, syb -any, transformers -any, utf8-string -any+    build-depends: base >=4 && <5, containers -any, directory -any,+                   filepath -any, mtl -any, parsec -any, purescript -any, syb -any,+                   transformers -any, utf8-string -any     type: exitcode-stdio-1.0     main-is: Main.hs     buildable: True
src/Language/PureScript.hs view
@@ -25,6 +25,7 @@ import Language.PureScript.Pretty as P import Language.PureScript.Sugar as P import Language.PureScript.Options as P+import Language.PureScript.ModuleDependencies as P  import Data.List (intercalate) import Control.Monad (when, forM)@@ -33,9 +34,10 @@  compile :: Options -> [Module] -> Either String (String, String, Environment) compile opts ms = do-  desugared <- desugar ms+  sorted <- sortModules ms+  desugared <- desugar sorted   (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> Module moduleName <$> typeCheckAll (ModuleName moduleName) decls-  let regrouped = createBindingGroupsModule . collapseBindingGroupsModule $ elaborated+  regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated   let js = concatMap (flip (moduleToJs opts) env) $ regrouped   let exts = intercalate "\n" . map (flip moduleToPs env) $ regrouped   js' <- case () of
src/Language/PureScript/CodeGen/JS.hs view
@@ -12,14 +12,17 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE DoAndIfThenElse #-}+ module Language.PureScript.CodeGen.JS (     module AST,     declToJs,     moduleToJs ) where -import Data.Maybe (mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import Data.List (sortBy)+import Data.Function (on)  import Control.Arrow (second) import Control.Monad (replicateM, forM)@@ -143,7 +146,9 @@ varToJs m e qual@(Qualified _ ident) = case M.lookup (qualify m qual) (names e) of   Just (_, ty) | isExtern ty -> JSVar ident   Just (_, Alias aliasModule aliasIdent) -> qualifiedToJS identToJs (Qualified (Just aliasModule) aliasIdent)-  _ -> qualifiedToJS identToJs qual+  _ -> case qual of+         Qualified Nothing _ -> JSVar ident+         _ -> qualifiedToJS identToJs qual   where   isExtern (Extern ForeignImport) = True   isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of@@ -182,12 +187,23 @@   return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing] binderToJs _ _ varName done (VarBinder ident) =   return (JSVariableIntroduction ident (Just (JSVar varName)) : done)-binderToJs m _ varName done (NullaryBinder ctor) =-  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing]+binderToJs m e varName done (NullaryBinder ctor) =+  if isOnlyConstructor m e ctor+  then+    return done+  else+    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock done) Nothing] binderToJs m e varName done (UnaryBinder ctor b) = do   value <- fresh   js <- binderToJs m e value done b-  return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor)))) (JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)) Nothing]+  let success = JSBlock (JSVariableIntroduction value (Just (JSAccessor "value" (JSVar varName))) : js)+  if isOnlyConstructor m e ctor+  then+    return [success]+  else+    return [JSIfElse (JSBinary EqualTo (JSAccessor "ctor" (JSVar varName)) (JSStringLiteral (show ((\(mp, nm) -> Qualified (Just mp) nm) $ qualify m ctor))))+                     success+                     Nothing] binderToJs m e varName done (ObjectBinder bs) = go done bs   where   go :: [JS] -> [(String, Binder)] -> Gen [JS]@@ -221,6 +237,18 @@ binderToJs m e varName done (NamedBinder ident binder) = do   js <- binderToJs m e varName done binder   return (JSVariableIntroduction ident (Just (JSVar varName)) : js)++isOnlyConstructor :: ModuleName -> Environment -> Qualified ProperName -> Bool+isOnlyConstructor m e ctor =+  let (ty, _) = fromMaybe (error "Data constructor not found") $ qualify m ctor `M.lookup` dataConstructors e+  in numConstructors ty == 1+  where+  numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e+  typeConstructor (TypeConstructor qual) = qualify m qual+  typeConstructor (ForAll _ ty) = typeConstructor ty+  typeConstructor (Function _ ty) = typeConstructor ty+  typeConstructor (TypeApp ty _) = typeConstructor ty+  typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn  statementToJs :: Options -> ModuleName -> Environment -> Statement -> JS statementToJs opts m e (VariableIntroduction ident value) = JSVariableIntroduction ident (Just (valueToJs opts m e value))
src/Language/PureScript/Declarations.hs view
@@ -39,7 +39,7 @@  data Declaration   = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]-  | DataBindingGroupDeclaration [(ProperName, [String], [(ProperName, Maybe Type)])]+  | DataBindingGroupDeclaration [Declaration]   | TypeSynonymDeclaration ProperName [String] Type   | TypeDeclaration Ident Type   | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value@@ -51,3 +51,33 @@   | TypeClassDeclaration ProperName String [Declaration]   | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]   deriving (Show, D.Data, D.Typeable)++isValueDecl :: Declaration -> Bool+isValueDecl (ValueDeclaration _ _ _ _) = True+isValueDecl _ = False++isDataDecl :: Declaration -> Bool+isDataDecl (DataDeclaration _ _ _) = True+isDataDecl (TypeSynonymDeclaration _ _ _) = True+isDataDecl _ = False++isImportDecl :: Declaration -> Bool+isImportDecl (ImportDeclaration _ _) = True+isImportDecl _ = False++isExternDataDecl :: Declaration -> Bool+isExternDataDecl (ExternDataDeclaration _ _) = True+isExternDataDecl _ = False++isFixityDecl :: Declaration -> Bool+isFixityDecl (FixityDeclaration _ _) = True+isFixityDecl _ = False++isExternDecl :: Declaration -> Bool+isExternDecl (ExternDeclaration _ _ _ _) = True+isExternDecl _ = False++isTypeClassDeclaration :: Declaration -> Bool+isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True+isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True+isTypeClassDeclaration _ = False
+ src/Language/PureScript/ModuleDependencies.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+--+-- Module      :  Language.PureScript.ModuleDependencies+-- Copyright   :  (c) Phil Freeman 2013+-- License     :  MIT+--+-- Maintainer  :  Phil Freeman <paf31@cantab.net>+-- Stability   :  experimental+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Language.PureScript.ModuleDependencies (+  sortModules+) where++import Data.Data+import Data.Graph+import Data.Generics+import Data.List (nub, intersect)+import Control.Applicative ((<$>))++import Language.PureScript.Declarations+import Language.PureScript.Names+import Language.PureScript.Values+import Language.PureScript.Types++sortModules :: [Module] -> Either String [Module]+sortModules ms = do+  let verts = map (\m -> (m, getModuleName m, usedModules m)) ms+  mapM toModule $ stronglyConnComp verts++collapseBindingGroups :: [Declaration] -> [Declaration]+collapseBindingGroups ds = concatMap go ds+  where+  go (DataBindingGroupDeclaration ds) = ds+  go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds+  go other = [other]++usedModules :: (Data d) => d -> [ProperName]+usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)+  where+  qualifiedIdents :: Qualified Ident -> [ProperName]+  qualifiedIdents (Qualified (Just (ModuleName pn)) _) = [pn]+  qualifiedIdents _ = []+  qualifiedProperNames :: Qualified ProperName -> [ProperName]+  qualifiedProperNames (Qualified (Just (ModuleName pn)) _) = [pn]+  qualifiedProperNames _ = []+  imports :: Declaration -> [ProperName]+  imports (ImportDeclaration (ModuleName pn) _) = [pn]+  imports _ = []++getModuleName :: Module -> ProperName+getModuleName (Module pn _) = pn++toModule :: SCC Module -> Either String Module+toModule (AcyclicSCC m) = return m+toModule (CyclicSCC [m]) = return m+toModule (CyclicSCC _) = Left "Cycle in module dependencies"
src/Language/PureScript/Sugar.hs view
@@ -31,4 +31,4 @@           >=> desugarDo           >=> desugarCasesModule           >=> desugarTypeDeclarationsModule-          >=> return . createBindingGroupsModule+          >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -23,49 +23,50 @@ import Data.Graph import Data.Generics import Data.List (nub, intersect)+import Control.Applicative ((<$>))  import Language.PureScript.Declarations import Language.PureScript.Names import Language.PureScript.Values import Language.PureScript.Types -createBindingGroupsModule :: [Module] -> [Module]-createBindingGroupsModule = map $ \(Module name ds) -> Module name (createBindingGroups ds)+createBindingGroupsModule :: [Module] -> Either String [Module]+createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds  collapseBindingGroupsModule :: [Module] -> [Module] collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds) -createBindingGroups :: [Declaration] -> [Declaration]-createBindingGroups ds =-  let-    values = filter isValueDecl ds-    dataDecls = filter isDataDecl ds-    nonValues = filter (\d -> not (isValueDecl d) && not (isDataDecl d)) ds-    allProperNames = map getProperName dataDecls-    dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls-    dataBindingGroupDecls = map toDataBindingGroup $ stronglyConnComp dataVerts-    allIdents = map getIdent values-    valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values-    bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts-  in-    dataBindingGroupDecls ++ nonValues ++ bindingGroupDecls+createBindingGroups :: [Declaration] -> Either String [Declaration]+createBindingGroups ds = do+  let values = filter isValueDecl ds+      dataDecls = filter isDataDecl ds+      allProperNames = map getProperName dataDecls+      dataVerts = map (\d -> (d, getProperName d, usedProperNames d `intersect` allProperNames)) dataDecls+  dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts+  let allIdents = map getIdent values+      valueVerts = map (\d -> (d, getIdent d, usedIdents d `intersect` allIdents)) values+      bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts+  return $ filter isImportDecl ds +++           filter isExternDataDecl ds +++           dataBindingGroupDecls +++           filter isTypeClassDeclaration ds +++           filter isFixityDecl ds +++           filter isExternDecl ds +++           bindingGroupDecls  collapseBindingGroups :: [Declaration] -> [Declaration] collapseBindingGroups ds = concatMap go ds   where-  go (DataBindingGroupDeclaration ds) = map (\(name, args, dctors) -> DataDeclaration name args dctors) ds+  go (DataBindingGroupDeclaration ds) = ds   go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds   go other = [other]  usedIdents :: (Data d) => d -> [Ident]-usedIdents = nub . everything (++) (mkQ [] namesV `extQ` namesS)+usedIdents = nub . everything (++) (mkQ [] names)   where-  namesV :: Value -> [Ident]-  namesV (Var (Qualified Nothing name)) = [name]-  namesV _ = []-  namesS :: Statement -> [Ident]-  namesS (VariableIntroduction name _) = [name]-  namesS _ = []+  names :: Value -> [Ident]+  names (Var (Qualified Nothing name)) = [name]+  names _ = []  usedProperNames :: (Data d) => d -> [ProperName] usedProperNames = nub . everything (++) (mkQ [] names)@@ -74,20 +75,13 @@   names (TypeConstructor (Qualified Nothing name)) = [name]   names _ = [] -isValueDecl :: Declaration -> Bool-isValueDecl (ValueDeclaration _ _ _ _) = True-isValueDecl _ = False--isDataDecl :: Declaration -> Bool-isDataDecl (DataDeclaration _ _ _) = True-isDataDecl _ = False- getIdent :: Declaration -> Ident getIdent (ValueDeclaration ident _ _ _) = ident getIdent _ = error "Expected ValueDeclaration"  getProperName :: Declaration -> ProperName getProperName (DataDeclaration pn _ _) = pn+getProperName (TypeSynonymDeclaration pn _ _) = pn getProperName _ = error "Expected DataDeclaration"  toBindingGroup :: SCC Declaration -> Declaration@@ -95,16 +89,18 @@ toBindingGroup (CyclicSCC [d]) = d toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds' -toDataBindingGroup :: SCC Declaration -> Declaration-toDataBindingGroup (AcyclicSCC d) = d-toDataBindingGroup (CyclicSCC [d]) = d-toDataBindingGroup (CyclicSCC ds') = DataBindingGroupDeclaration $ map fromDataDecl ds'+toDataBindingGroup :: SCC Declaration -> Either String Declaration+toDataBindingGroup (AcyclicSCC d) = return d+toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn+toDataBindingGroup (CyclicSCC [d]) = return d+toDataBindingGroup (CyclicSCC ds')+  | all isTypeSynonym ds' = Left "Cycle in type synonyms"+  | otherwise = return $ DataBindingGroupDeclaration ds'+  where+  isTypeSynonym (TypeSynonymDeclaration _ _ _) = True+  isTypeSynonym _ = False  fromValueDecl :: Declaration -> (Ident, Value) fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val) fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared" fromValueDecl _ = error "Expected ValueDeclaration"--fromDataDecl :: Declaration -> (ProperName, [String], [(ProperName, Maybe Type)])-fromDataDecl (DataDeclaration pn args ctors) = (pn, args, ctors)-fromDataDecl _ = error "Expected DataDeclaration"
src/Language/PureScript/Sugar/Operators.hs view
@@ -96,9 +96,6 @@   collectFixities (M.insert qual fixity m) moduleName rest collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do   let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]-  forM_ fs $ \(name, _) -> do-    let qual = Qualified (Just moduleName) name-    when (qual `M.member` m) (Left $ "redefined fixity for " ++ show name)   let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)   collectFixities (M.union m' m) moduleName rest collectFixities m moduleName (_:ds) = collectFixities m moduleName ds
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -73,22 +73,29 @@  typeInstanceDictionaryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> [Declaration] -> Desugar Declaration typeInstanceDictionaryDeclaration mn deps name ty decls = do+  m <- get+  (arg, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right+                        $ M.lookup (qualify mn name) m+  let memberTypes = map (replaceTypeVars arg ty) instanceTys   entryName <- lift $ mkDictionaryValueName mn name ty-  memberNames <- mapM memberToNameAndValue decls+  memberNames <- mapM (memberToNameAndValue memberTypes) decls   return $ ValueDeclaration entryName [] Nothing-    (TypedValue False+    (TypedValue True       (Abs         (map (\n -> Ident ('_' : show n)) [1..length deps])         (ObjectLiteral memberNames))       (quantify (Function (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps) (TypeApp (TypeConstructor name) ty)))     )   where-  memberToNameAndValue :: Declaration -> Desugar (String, Value)-  memberToNameAndValue (ValueDeclaration ident _ _ _) = do+  memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)+  memberToNameAndValue tys (ValueDeclaration ident _ _ _) = do+    memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys     memberName <- mkDictionaryEntryName mn name ty ident-    return (identToJs ident, if null deps then Var (Qualified Nothing memberName)-                             else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))-  memberToNameAndValue _ = error "Invalid declaration in type instance definition"+    return (identToJs ident, TypedValue False+                               (if null deps then Var (Qualified Nothing memberName)+                                else App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))+                               (quantify memberType))+  memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"  typeInstanceDictionaryEntryDeclaration :: ModuleName -> [(Qualified ProperName, Type)] -> Qualified ProperName -> Type -> Declaration -> Desugar Declaration typeInstanceDictionaryEntryDeclaration mn deps name ty (ValueDeclaration ident [] _ val) = do@@ -123,9 +130,10 @@ typeToString _ Number = return "number" typeToString _ Boolean = return "boolean" typeToString _ Array = return "array"+typeToString _ (TypeVar _) = return "var" typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty' typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'-typeToString _ _ = Left "Type class instance must be of the form T a1 ... an"+typeToString a b = Left $ "Type class instance must be of the form T a1 ... an " ++ show (a, b)  mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident mkDictionaryEntryName mn name ty ident = do
src/Language/PureScript/TypeChecker.hs view
@@ -98,14 +98,23 @@   ds <- typeCheckAll moduleName rest   return $ d : ds typeCheckAll moduleName (d@(DataBindingGroupDeclaration tys) : rest) = do-  rethrow (("Error in data binding group " ++ show (map (\(name, _, _) -> name) tys) ++ ":\n") ++) $ do-    forM_ tys $ \(name, _, _) ->+  rethrow ("Error in data binding group:\n" ++) $ do+    let syns = mapMaybe toTypeSynonym tys+    let dataDecls = mapMaybe toDataDecl tys+    (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) dataDecls)+    forM_ (zip dataDecls data_ks) $ \((name, args, dctors), ctorKind) -> do       typeIsNotDefined moduleName name-    ks <- kindsOfAll moduleName (map (\(name, args, dctors) -> (name, args, mapMaybe snd dctors)) tys)-    forM_ (zip tys ks) $ \((name, args, dctors), ctorKind) ->       addDataType moduleName name args dctors ctorKind+    forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do+      typeIsNotDefined moduleName name+      addTypeSynonym moduleName name args ty kind   ds <- typeCheckAll moduleName rest   return $ d : ds+  where+  toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)+  toTypeSynonym _ = Nothing+  toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)+  toDataDecl _ = Nothing typeCheckAll moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do   rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do     typeIsNotDefined moduleName name
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -68,16 +68,27 @@   bindLocalTypeVariables moduleName dict $     solveTypes ts kargs tyCon -kindsOfAll :: ModuleName -> [(ProperName, [String], [Type])] -> Check [Kind]-kindsOfAll moduleName tys = fmap (map starIfUnknown . (\(ks, s) -> apply s ks)) . runSubst (SubstContext moduleName) $ do-  tyCons <- replicateM (length tys) fresh-  let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons-  bindLocalTypeVariables moduleName dict $-    zipWithM (\tyCon (_, args, ts) -> do-      kargs <- replicateM (length args) fresh-      let argDict = zip (map ProperName args) kargs-      bindLocalTypeVariables moduleName argDict $-        solveTypes ts kargs tyCon) tyCons tys+kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])+kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do+  synVars <- replicateM (length syns) fresh+  let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars+  bindLocalTypeVariables moduleName dict $ do+    tyCons <- replicateM (length tys) fresh+    let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons+    bindLocalTypeVariables moduleName dict $ do+      data_ks <- zipWithM (\tyCon (_, args, ts) -> do+        kargs <- replicateM (length args) fresh+        let argDict = zip (map ProperName args) kargs+        bindLocalTypeVariables moduleName argDict $+          solveTypes ts kargs tyCon) tyCons tys+      syn_ks <- zipWithM (\synVar (_, args, ty) -> do+        kargs <- replicateM (length args) fresh+        let argDict = zip (map ProperName args) kargs+        bindLocalTypeVariables moduleName argDict $+          solveTypes [ty] kargs synVar) synVars syns+      return (syn_ks, data_ks)+  where+  tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)  solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind solveTypes ts kargs tyCon = do