InstanceCreator.hs

{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses
  , OverlappingInstances, UndecidableInstances #-}

{-# OPTIONS -fglasgow-exts #-}

module Graphics.UI.AF.General.InstanceCreator
    ( createInstance, createInstance'
    , gInstanceCreatorCtx, GInstanceCreator, gGenUpTo
    )

where

import Graphics.UI.AF.General.MySYB
-- import Graphics.UI.AF.General.CustomTypes

-- The function below is heavily inspired of "Test-data generator"
-- example from SYB2 paper.
--
-- |Creates an instance of a Haskell type. For this to work the compiler
--  must be able to deduce the type from the callee's context.
createInstance :: GInstanceCreator a => Maybe a
createInstance = helper 1  -- Zero newer returns anything
    where
      --helper :: Int -> a
      helper 8   = Nothing   -- Make sure we do not to loop eternally or for a very, very long time.
      helper x   = if (length generate) == 0
                     then helper (x+1)
                     else Just $ head generate
          where
            generate = (gGenUpToD dict) x

-- |Like 'createInstance' excepts it uses a phantom type to elicit the
--  correct type to return.
createInstance' :: GInstanceCreator a
                => a          -- ^Not evaluated. Only used to force the right type.
                -> Maybe a
createInstance' _ = createInstance


-- |The dictionary type for the GInstanceCreator class
data GInstanceCreatorD a = GInstanceCreatorD { gGenUpToD  :: Int -> [a] }

-- |Instantiation of the Sat class
instance GInstanceCreator a => Sat (GInstanceCreatorD a)
  where  dict = GInstanceCreatorD { gGenUpToD  = gGenUpTo }

-- |The context for generic autoform
gInstanceCreatorCtx :: Proxy GInstanceCreatorD
gInstanceCreatorCtx = error "gInstanceCreatorCtx"

-- |Used to creates instances of data types
class (Data GInstanceCreatorD a) => GInstanceCreator a
    where
    -- This code is heavily inspired of the "Test-data generator" example in the SYB2 paper.

    -- |Generates all possible instances of a, while using no more
    -- than n levels of recursion. Each subtype requires another level
    -- of recursion. For example:
    --
    -- Branch (Branch Leaf 17) (Leaf 3)
    --
    -- would require 4 levels of recursion. One for the first branch,
    -- one for second branch, one for the left Leaf, and one for the
    -- Int (the seventeen). The right part of the first branch (Left
    -- 3) would be done in two recursions.
    gGenUpTo :: Int   -- ^ Max number of recursions
             -> [a]
    gGenUpTo 0 = []
    gGenUpTo d = result
        where
          -- Recurse per possible constructor
          result = concat (map recurse cons)
          -- Retrieve constructors of the requested type
          -- cons :: (Data ctx a) => ctx() -> [Constr]
          cons = case dataTypeRep ty of
                   AlgRep cs   -> cs
                   IntRep      -> [mkIntConstr ty 0]
                   FloatRep    -> [mkFloatConstr ty 0]
                   StringRep   -> [mkStringConstr ty "f"] -- Also used for char, so we changed foo to f
                                                          -- Or Maybe SYB3/Instances.hs should be changed
                   NoRep       -> [] -- error "InstanceCreator: NoRep"
              where
                ty = dataTypeOf gInstanceCreatorCtx (head result)
          -- Find all terms headed by a specific Constr
          recurse :: Constr -> [a]
          recurse = fromConstrM gInstanceCreatorCtx ((gGenUpToD dict) (d-1))

{-
instance GInstanceCreator Bool
instance GInstanceCreator Int
instance GInstanceCreator Char
instance GInstanceCreator Float
instance GInstanceCreator Double
instance (GInstanceCreator a) => GInstanceCreator (Maybe a)
instance (GInstanceCreator a) => GInstanceCreator [a]
instance GInstanceCreator AFFilePath
instance GInstanceCreator AFDirectoryPath
-}

instance (Data GInstanceCreatorD a) => GInstanceCreator a