Make the C-- O and C types constructors with DataKinds

The tightens up the kinds a bit. I use type synnonyms to avoid adding
promotion ticks everywhere.

5 files changed, 31 insertions, 18 deletions

diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
index 5c31932934..07aafe8ae9 100644
--- a/compiler/cmm/Hoopl/Block.hs
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -1,12 +1,15 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
 module Hoopl.Block
-    ( C
+    ( Extensibility (..)
     , O
+    , C
     , MaybeO(..)
     , IndexedCO
     , Block(..)
@@ -40,19 +43,21 @@ import GhcPrelude
 -- -----------------------------------------------------------------------------
 -- Shapes: Open and Closed
 
--- | Used at the type level to indicate an "open" structure with
--- a unique, unnamed control-flow edge flowing in or out.
--- "Fallthrough" and concatenation are permitted at an open point.
-data O
+-- | Used at the type level to indicate "open" vs "closed" structure.
+data Extensibility
+  -- | An "open" structure with a unique, unnamed control-flow edge flowing in
+  -- or out. "Fallthrough" and concatenation are permitted at an open point.
+  = Open
+  -- | A "closed" structure which supports control transfer only through the use
+  -- of named labels---no "fallthrough" is permitted. The number of control-flow
+  -- edges is unconstrained.
+  | Closed
 
--- | Used at the type level to indicate a "closed" structure which
--- supports control transfer only through the use of named
--- labels---no "fallthrough" is permitted.  The number of control-flow
--- edges is unconstrained.
-data C
+type O = 'Open
+type C = 'Closed
 
 -- | Either type indexed by closed/open using type families
-type family IndexedCO ex a b :: *
+type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k
 type instance IndexedCO C a _b = a
 type instance IndexedCO O _a b = b
 
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index bf12b3f6a1..2a2bb72dcc 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -1,9 +1,11 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+
 {-# OPTIONS_GHC -fprof-auto-top #-}
 
 --
@@ -49,7 +51,7 @@ import Hoopl.Graph
 import Hoopl.Collections
 import Hoopl.Label
 
-type family   Fact x f :: *
+type family   Fact (x :: Extensibility) f :: *
 type instance Fact C f = FactBase f
 type instance Fact O f = f
 
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
index 0142f70c76..992becb417 100644
--- a/compiler/cmm/Hoopl/Graph.hs
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
@@ -30,7 +31,7 @@ import Hoopl.Collections
 type Body n = LabelMap (Block n C C)
 
 -- | @Body@ abstracted over @block@
-type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
+type Body' block (n :: Extensibility -> Extensibility -> *) = LabelMap (block n C C)
 
 -------------------------------
 -- | Gives access to the anchor points for
@@ -75,7 +76,7 @@ type Graph = Graph' Block
 -- | @Graph'@ is abstracted over the block type, so that we can build
 -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
 -- needs this).
-data Graph' block (n :: * -> * -> *) e x where
+data Graph' block (n :: Extensibility -> Extensibility -> *) e x where
   GNil  :: Graph' block n O O
   GUnit :: block n O O -> Graph' block n O O
   GMany :: MaybeO e (block n O C)
diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
index d01c31f5fd..5e34b28793 100644
--- a/compiler/nativeGen/BlockLayout.hs
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -2,7 +2,10 @@
 -- Copyright (c) 2018 Andreas Klebinger
 --
 
-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module BlockLayout
     ( sequenceTop )
@@ -512,7 +515,7 @@ buildChains succWeights blocks
 
 
 -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
-newtype BlockNode e x = BN (BlockId,[BlockId])
+newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId])
 instance NonLocal (BlockNode) where
   entryLabel (BN (lbl,_))   = lbl
   successors (BN (_,succs)) = succs
diff --git a/testsuite/tests/cmm/should_run/HooplPostorder.hs b/testsuite/tests/cmm/should_run/HooplPostorder.hs
index d7a8bbaef1..269efa4021 100644
--- a/testsuite/tests/cmm/should_run/HooplPostorder.hs
+++ b/testsuite/tests/cmm/should_run/HooplPostorder.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
 module Main where
 
 import Hoopl.Block
@@ -7,7 +9,7 @@ import Hoopl.Label
 
 import Data.Maybe
 
-data TestBlock e x = TB { label_ :: Label, successors_ :: [Label] }
+data TestBlock (e :: Extensibility) (x :: Extensibility) = TB { label_ :: Label, successors_ :: [Label] }
     deriving (Eq, Show)
 
 instance NonLocal TestBlock where