Quern.hs

*Prelude> :r
[2 of 2] Compiling Quern            ( C:\Users\chris\Documents\Haskell\Maxwell\Maxwell\test-suite\Quern.hs, interpreted )

C:\Users\chris\Documents\Haskell\Maxwell\Maxwell\test-suite\Quern.hs:60:15: error:
    * Illegal polymorphic type: Lens' RingInt Int
      GHC doesn't yet support impredicative polymorphism
    * In the type signature:
        runStage :: Lens' Stages Int
                    -> (Lens' RingInt Int, Lens' RingInt Int) -> State RingInt ()
      In an equation for `rotate':
          rotate ring stages
            = map4 toDir
                $ each execState (fromDir ring)
                    $ do runStage _1 (_3, _4)
                         runStage _2 (_3, _1)
                         runStage _3 (_4, _2)
                         ....
            where
                runStage ::
                  Lens' Stages Int
                  -> (Lens' RingInt Int, Lens' RingInt Int) -> State RingInt ()
                runStage stageLens (ring0, ring1)
                  = let ... in ring0 += stageVal >> ring1 += stageVal
   |
60 |   runStage :: Lens' Stages Int -> (Lens' RingInt Int, Lens' RingInt Int) -> State RingInt ()
   |               ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
------------------------

data Dir = TopD | RightD | BottomD | LeftD deriving (Eq, Show)

fromDir TopD = 0
fromDir RightD = 1
fromDir BottomD = 2
fromDir LeftD = 3

toDir 0 = TopD
toDir 1 = RightD
toDir 2 = BottomD
toDir 3 = LeftD
toDir n = toDir (n `rem` 4)

type Ring = (Dir, Dir, Dir, Dir)
type RingInt = (Int, Int, Int, Int)
type Stages = (Int, Int, Int, Int) -- Range from -3 to +2, (but toDir means that -3 has the same effect as +1, and such)

rotate :: Ring -> Stages -> Ring
rotate ring stages =
  map4 toDir $
    each execState (fromDir ring) $ do
      runStage _1 (_3, _4)
      runStage _2 (_3, _1)  
      runStage _3 (_4, _2)
      runStage _4 (_1, _2)
  where
  runStage :: Lens' Stages Int -> (Lens' RingInt Int, Lens' RingInt Int) -> State RingInt ()
  runStage stageLens (ring0, ring1) = 
    let stageVal = (get stageLens stages :: Int) in 
    ring0 += stageVal >> ring1 += stageVal

map4 :: (a -> b) -> (a, a, a, a) -> (b, b, b, b)
map4 k (a1, a2, a3, a4) = (k a1, k a2, k a3, k a4)