[added user defined kind extension
John Meacham <john@repetae.net>**20120211042248
 Ignore-this: ded329985c5c81aa8c4612f7aa19559b
] hunk ./src/DataConstructors.hs 118
+kind (KBase (KNamed t)) = ESort (ESortNamed t)
hunk ./src/DataConstructors.hs 120
-kind (KVar _) = error "Kind variable still existing."
-kind _ = error "DataConstructors.kind"
+kind k = error $ "DataConstructors.kind: cannot convert " ++ show k
hunk ./src/DataConstructors.hs 287
+sortName :: ESort -> Name
+sortName s = f s where
+    f EStar          = s_Star     -- ^ the sort of boxed lazy types
+    f EBang          = s_Bang     -- ^ the sort of boxed strict types
+    f EHash          = s_Hash     -- ^ the sort of unboxed types
+    f ETuple         = s_Tuple    -- ^ the sort of unboxed tuples
+    f EHashHash      = s_HashHash -- ^ the supersort of unboxed types
+    f EStarStar      = s_StarStar -- ^ the supersort of boxed types
+    f (ESortNamed n) = n          -- ^ user defined sorts
+
+sortConstructor name ss = emptyConstructor {
+    conName = name,
+    conType = ESort ss,
+    conExpr = ESort (ESortNamed name),
+    conInhabits = sortName ss
+}
+
hunk ./src/DataConstructors.hs 570
-    newDataTable = DataTable (Map.mapWithKey fixupMap $ Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` keys primitiveAliases ])
+    newDataTable = DataTable (Map.mapWithKey fixupMap $
+        Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` keys primitiveAliases ])
hunk ./src/DataConstructors.hs 583
-    f decl@HsNewTypeDecl {  hsDeclName = nn, hsDeclCon = c } = dt decl (if nn `elem` newtypeLoopBreakers then RecursiveAlias else ErasedAlias)  [c]
-    f decl@HsDataDecl {  hsDeclCons = cs } = dt decl NotAlias  cs
+    f decl@HsNewTypeDecl {  hsDeclName = nn, hsDeclCon = c } =
+        dt decl (if nn `elem` newtypeLoopBreakers then RecursiveAlias else ErasedAlias)  [c]
+    f decl@HsDataDecl { hsDeclKindDecl = True } = dkind decl
+    f decl@HsDataDecl { hsDeclCons = cs } = dt decl NotAlias  cs
hunk ./src/DataConstructors.hs 617
+    dkind HsDataDecl { .. } = do
+        tell $ Seq.singleton $ (sortConstructor hsDeclName EHashHash) {
+            conChildren = DataNormal (map hsConDeclName hsDeclCons) }
+        flip mapM_  hsDeclCons $ \ HsConDecl { .. } -> do
+            let Just theKind = kind `fmap` (Map.lookup hsConDeclName km)
+                (theTypeFKind,theTypeKArgs') = fromPi theKind
+                theTypeArgs = [ tvr { tvrIdent = x } | tvr  <- theTypeKArgs' | x <- anonymousIds ]
+                theTypeExpr = ELit litCons {
+                    litName = hsConDeclName,
+                    litArgs = map EVar theTypeArgs,
+                    litType = theTypeFKind }
+            tell $ Seq.singleton emptyConstructor {
+                conName      = hsConDeclName,
+                conType      = theKind,
+                conOrigSlots = map (SlotNormal . tvrType) theTypeArgs,
+                conExpr      = foldr ($) theTypeExpr (map ELam theTypeArgs),
+                conInhabits  = hsDeclName
+            }
+
hunk ./src/DataConstructors.hs 697
-        theKind = kind $ fromJust (Map.lookup theTypeName km)
+        Just theKind = kind `fmap` (Map.lookup theTypeName km)
hunk ./src/FrontEnd/KindInfer.hs 377
-kiInitClasses ds = do
-    mapM_ kiInitDecl ds
+kiInitClasses ds = do mapM_ kiInitDecl ds
+
hunk ./src/FrontEnd/KindInfer.hs 386
-
hunk ./src/FrontEnd/KindInfer.hs 399
+    f HsDataDecl { hsDeclKindDecl = True, .. } = kiDataKind hsDeclName hsDeclCons
hunk ./src/FrontEnd/KindInfer.hs 492
+kiDataKind tyconName condecls = do
+    unless (nameType tyconName == SortName) $ fail "tycon isn't sort"
+    flip mapM_  condecls $ \ HsConDecl { .. } -> do
+        kc <- lookupKind KindAny (toName TypeConstructor hsConDeclName)
+        let args = [ KBase (KNamed t) | HsTyCon t <- map hsBangType hsConDeclConArg ]
+        kiApps' kc args (KBase (KNamed tyconName))
+
hunk ./src/FrontEnd/Rename.hs 26
+import qualified FrontEnd.SrcLoc
hunk ./src/FrontEnd/Rename.hs 187
-    rename (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = do
-        withSrcLoc srcLoc $ do
+    rename d = withSrcLoc (FrontEnd.SrcLoc.srcLoc d) $ renameHsDecl d
+
+renameHsDecl d = f d where
+    f (HsPatBind srcLoc hsPat hsRhs {-where-} hsDecls) = do
hunk ./src/FrontEnd/Rename.hs 196
-
-    rename (HsForeignExport a b n t) = do
-        withSrcLoc a $ do
+    f (HsForeignExport a b n t) = do
hunk ./src/FrontEnd/Rename.hs 201
-
-    rename (HsForeignDecl a b n t) = do
-        withSrcLoc a $ do
+    f (HsForeignDecl a b n t) = do
hunk ./src/FrontEnd/Rename.hs 206
-
-    rename (HsFunBind hsMatches) = do
+    f (HsFunBind hsMatches) = do
hunk ./src/FrontEnd/Rename.hs 209
-
-    rename (HsTypeSig srcLoc hsNames hsQualType) = do
-        withSrcLoc srcLoc $ do
+    f (HsTypeSig srcLoc hsNames hsQualType) = do
hunk ./src/FrontEnd/Rename.hs 214
-    rename dl@HsDataDecl { hsDeclSrcLoc = srcLoc, hsDeclContext = hsContext, hsDeclName = hsName, hsDeclArgs = hsNames1, hsDeclCons = hsConDecls, hsDeclDerives = hsNames2 } = do
-        withSrcLoc srcLoc $ do
-        hsName' <- renameTypeName hsName
-        updateWith (map fromTypishHsName hsNames1) $ do
-            hsContext' <- rename hsContext
-            hsNames1' <- mapM renameTypeName hsNames1 -- TODO
-            hsConDecls' <- rename hsConDecls
-            hsNames2' <- mapM (renameName . toName ClassName) hsNames2
-            return dl { hsDeclContext = hsContext', hsDeclName = hsName', hsDeclArgs = hsNames1', hsDeclCons = hsConDecls', hsDeclDerives = hsNames2' }
-    rename (HsTypeDecl srcLoc name hsNames t) = do
-        withSrcLoc srcLoc $ do
+    f HsDataDecl { .. } | hsDeclKindDecl = do
+        hsDeclName <- renameKindName hsDeclName
+        unless (null hsDeclArgs) $
+            addWarn InvalidDecl "kind declarations can't have arguments."
+        when (any isHsRecDecl hsDeclCons) $
+            addWarn InvalidDecl "kind declarations can't have records."
+        hsDeclCons <- mapM renameKindHsCon hsDeclCons
+        unless (null hsDeclDerives) $
+            addWarn InvalidDecl "kind declarations can't derive classes"
+        unless (null hsDeclContext) $
+            addWarn InvalidDecl "kind declarations can't have context"
+        return HsDataDecl { .. }
+    f HsDataDecl { .. } = do
+        hsDeclName <- renameTypeName hsDeclName
+        updateWith (map fromTypishHsName hsDeclArgs) $ do
+            hsDeclContext <- rename hsDeclContext
+            hsDeclArgs <- mapM renameTypeName hsDeclArgs
+            hsDeclCons <- rename hsDeclCons
+            hsDeclDerives <- mapM (renameName . toName ClassName) hsDeclDerives
+            return HsDataDecl { .. }
+    f (HsTypeDecl srcLoc name hsNames t) = do
hunk ./src/FrontEnd/Rename.hs 240
-    rename HsTypeFamilyDecl { .. } = do
-        withSrcLoc hsDeclSrcLoc $ do
+    f HsTypeFamilyDecl { .. } = do
hunk ./src/FrontEnd/Rename.hs 245
-    rename (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) = do
-        withSrcLoc srcLoc $ do
+    f (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) = do
hunk ./src/FrontEnd/Rename.hs 253
-    rename (HsClassDecl srcLoc classHead hsDecls) = do
-        withSrcLoc srcLoc $ do
+    f (HsClassDecl srcLoc classHead hsDecls) = do
hunk ./src/FrontEnd/Rename.hs 257
-    rename (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = do
-        withSrcLoc srcLoc $ do
+    f (HsClassAliasDecl srcLoc name args hsContext hsClasses hsDecls) = do
hunk ./src/FrontEnd/Rename.hs 265
-    rename (HsInstDecl srcLoc classHead hsDecls) = do
-        withSrcLoc srcLoc $ do
+    f (HsInstDecl srcLoc classHead hsDecls) = do
hunk ./src/FrontEnd/Rename.hs 270
-    rename (HsInfixDecl srcLoc assoc int hsNames) = do
-        withSrcLoc srcLoc $ do
+    f (HsInfixDecl srcLoc assoc int hsNames) = do
hunk ./src/FrontEnd/Rename.hs 273
-    rename (HsActionDecl srcLoc pat e) = do
-        withSrcLoc srcLoc $ do
+    f (HsActionDecl srcLoc pat e) = do
hunk ./src/FrontEnd/Rename.hs 277
-    rename (HsPragmaProps srcLoc prop hsNames) = do
-        withSrcLoc srcLoc $ do
+    f (HsPragmaProps srcLoc prop hsNames) = do
hunk ./src/FrontEnd/Rename.hs 280
-    rename (HsPragmaRules rs) = do
+    f (HsPragmaRules rs) = do
hunk ./src/FrontEnd/Rename.hs 283
-    rename prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } = do
-        withSrcLoc srcLoc $ do
+    f prules@HsPragmaSpecialize { hsDeclSrcLoc = srcLoc, hsDeclName = n, hsDeclType = t } = do
hunk ./src/FrontEnd/Rename.hs 294
-    rename (HsDefaultDecl sl e) = HsDefaultDecl sl <$> rename e
-    rename (HsDeclDeriving sl ch) = HsDeclDeriving sl <$> rename ch
-    rename h = error $ "renameerr: " ++ show h
+    f (HsDefaultDecl sl e) = HsDefaultDecl sl <$> rename e
+    f (HsDeclDeriving sl ch) = HsDeclDeriving sl <$> rename ch
+    f h = error $ "renameerr: " ++ show h
hunk ./src/FrontEnd/Rename.hs 342
+renameKindHsCon HsConDecl { .. } = do
+    withSrcLoc hsConDeclSrcLoc $ do
+    hsConDeclName <- renameTypeName hsConDeclName
+    unless (null hsConDeclExists) $
+        addWarn InvalidDecl "kind declarations cannot have existential types"
+    let bt e@HsBangedTy {} = do
+            addWarn InvalidDecl "strictness annotations not relevant to kind declarations"
+            return e
+        bt (HsUnBangedTy e) = HsUnBangedTy `liftM` f e
+        f (HsTyCon n) = HsTyCon `liftM` renameKindName n
+        f e = addWarn InvalidDecl "invalid argument in kind declaration" >> return e
+    hsConDeclConArg <- mapM bt hsConDeclConArg
+    return HsConDecl { .. }
+
hunk ./src/FrontEnd/Rename.hs 636
+renameKindName :: Name -> RM Name
+renameKindName hsName = renameName (toName SortName hsName)
+
hunk ./src/FrontEnd/Rename.hs 743
+    f HsDataDecl { hsDeclKindDecl = True, hsDeclSrcLoc =sl, hsDeclName = n, hsDeclCons = cs } = do
+        tellF $ (toName SortName n,sl,snub [ x |(x,_,_) <- cs']): cs' ; zup cs where
+            cs' = concatMap (namesHsConDeclSort' toName) cs
hunk ./src/FrontEnd/Rename.hs 771
+    namesHsConDeclSort' toName c = [dc] where
+        dc = (toName TypeConstructor $ hsConDeclName c,sl,[])
+        sl = hsConDeclSrcLoc c
+
hunk ./src/Name/Name.hs 213
-
hunk ./src/Name/Name.hs 227
-
hunk ./src/Name/Names.hs 48
-s_Star = toName SortName (Module "Jhc@","*"::String)
-s_Hash = toName SortName (Module "Jhc@","#"::String)
-s_Bang = toName SortName (Module "Jhc@","!"::String)
+-- quasi-kinds (placeholders for existential kinds)
hunk ./src/Name/Names.hs 52
+s_Any = toName SortName (Module "Jhc@","ANY"::String)
hunk ./src/data/names.txt 183
+SortName:s:
+# kinds
+Star Jhc@.*
+Hash Jhc@.#
+Bang Jhc@.!
+Tuple Jhc@.(#)
+
+# superkinds
+HashHash  Jhc@.##
+StarStar  Jhc@.**
+
hunk ./utils/op_names.prl 69
-    /^([_A-Za-z0-9]+)\s+(([0-9_A-Za-z.@]+)\.)?([-0-9)(#&|><=\/A-Za-z%:_\[\]]+)\s*$/ or die "unrecognized line $_";
+    /^([_A-Za-z0-9]+)\s+(([0-9_A-Za-z.@]+)\.)?([-0-9*!)(#&|><=\/A-Za-z%:_\[\]]+)\s*$/ or die "unrecognized line $_";