-----------------------------------------------------------------------------
-- |
-- Module      :  Finite.TH
-- Maintainer  :  Felix Klein
--
-- Template haskell for easy instance generation using newtypes.
--
-----------------------------------------------------------------------------

{-# LANGUAGE

    LambdaCase
  , ImplicitParams
  , TemplateHaskell
  , CPP

  #-}

-----------------------------------------------------------------------------

module Finite.TH
  ( newInstance
  , baseInstance
  , newBaseInstance
  , extendInstance
  , polyType
  ) where

-----------------------------------------------------------------------------

import qualified Data.Ix
  ( Ix
  , index
  , range
  , inRange
  )

import Test.QuickCheck
  ( Arbitrary
  , arbitrary
  , shrink
  )

import Data.Hashable
  ( Hashable
  , hashWithSalt
  )

import Finite.Type
  ( T
  , FiniteBounds
  )

import Finite.Class
  ( Finite(..)
  )

import Data.Char
  ( toLower
  , isUpper
  )

import Control.Exception
  ( assert
  )

import Language.Haskell.TH
  ( Q
  , Dec
  , Exp
#if MIN_VERSION_template_haskell(2,12,0)
  , DerivClause(..)
#endif
  , Type(..)
  , mkName
  , conT
  , appT
  , conP
  , varP
  , tupP
  , wildP
  , varE
  , conE
  , tupE
  , appE
  , funD
  , newtypeD
  , instanceD
  , recC
  , normalB
  , cxt
  , clause
  , bangType
  , varBangType
  , bang
  , noSourceUnpackedness
  , noSourceStrictness
  )

-----------------------------------------------------------------------------

-- | Creates a new basic type using the name provided as a string. The
-- template defines the corresponding data type using the provided
-- name and a corresponding access function using the same name with
-- the first letter moved to lower case. Furthermore, it also
-- instanciates corresponding `Show`, `Hashable`, 'Ix', 'Arbitrary',
-- and 'Num' instances.
--
-- >>> newInstance "Example"
-- <BLANKLINE>
-- newtype Example =
--   Example { example :: Int }
--   deriving (Eq, Ord)
-- <BLANKLINE>
-- instance Show Example where
--   show (Example x) = show x
-- <BLANKLINE>
-- instance Hashable Example where
--   hashWithSalt s (Example x) = hashWithSalt s x
-- <BLANKLINE>
-- instance Ix Example where
--   range (l,u) = map Example $ range (example l, example u)
--   index (l,u) x = index (example l, example u) (example x)
--   inRange (l,u) x = inRange (example l, example u) (example x)
-- <BLANKLINE>
-- instance Arbitrary Example where
--   arbitrary = Example <$> arbitrary
--   shrink (Example x) = map Example $ shrink x
-- <BLANKLINE>
-- instance Num Example where
--   (Example x) + (Example y) = Example (a + b)
--   (Example x) - (Example y) = Example (a - b)
--   (Example x) * (Example y) = Example (a * b)
--   abs = Example . abs . example
--   negate = Example . negage . example
--   signum = Example . signum . example
--   fromInteger = Example . fromInteger

newInstance
  :: String -> Q [Dec]

newInstance :: String -> Q [Dec]
newInstance = \case
  [] -> Bool -> Q [Dec] -> Q [Dec]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Q [Dec]
forall a. (?callStack::CallStack) => a
undefined
  (Char
x:String
xr) -> Bool -> Q [Dec] -> Q [Dec]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Char -> Bool
isUpper Char
x) (Q [Dec] -> Q [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ do
    let
      tmpV :: Name
tmpV = String -> Name
mkName String
"x"
      conC :: Name
conC = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xr
      accV :: Name
accV = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xr
      emptyContext :: Q Cxt
emptyContext = [Q Pred] -> Q Cxt
forall (m :: * -> *). Quote m => [m Pred] -> m Cxt
cxt []
      intT :: Q Pred
intT = Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Int)

    Dec
d_newtype <-
      Q Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Pred
-> Q Con
-> [Q DerivClause]
-> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt
-> Name
-> [TyVarBndr BndrVis]
-> Maybe Pred
-> m Con
-> [m DerivClause]
-> m Dec
newtypeD
        -- no context
        Q Cxt
emptyContext
        -- newtype name
        Name
conC
        -- no type parameters
        []
        -- no kinds
        Maybe Pred
forall a. Maybe a
Nothing
        -- newtype constructor
        (Name -> [Q VarBangType] -> Q Con
forall (m :: * -> *). Quote m => Name -> [m VarBangType] -> m Con
recC -- normalC
           Name
conC
           [Name -> Q BangType -> Q VarBangType
forall (m :: * -> *).
Quote m =>
Name -> m BangType -> m VarBangType
varBangType
              Name
accV
              (Q Bang -> Q Pred -> Q BangType
forall (m :: * -> *). Quote m => m Bang -> m Pred -> m BangType
bangType
                (Q SourceUnpackedness -> Q SourceStrictness -> Q Bang
forall (m :: * -> *).
Quote m =>
m SourceUnpackedness -> m SourceStrictness -> m Bang
bang Q SourceUnpackedness
forall (m :: * -> *). Quote m => m SourceUnpackedness
noSourceUnpackedness Q SourceStrictness
forall (m :: * -> *). Quote m => m SourceStrictness
noSourceStrictness)
                Q Pred
intT)])
        -- derive 'Eq' and 'Ord'
#if MIN_VERSION_template_haskell(2,12,0)
        [ DerivClause -> Q DerivClause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause
                  Maybe DerivStrategy
forall a. Maybe a
Nothing
                  [ Name -> Pred
ConT (''Eq)
                  , Name -> Pred
ConT (''Ord)
        ])
        ]
#else
        (return [ConT (''Eq), ConT (''Ord)])
#endif

    Dec
d_show_instance <-
      Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
        -- no context
        Q Cxt
emptyContext
        -- instance of 'Show'
        (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Show)) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
conC))
        -- declare 'show'
        [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('show)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]]
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('show)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
                --
                [] ] ]

    Dec
d_hashable_instance <-
      Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
        -- no context
        Q Cxt
emptyContext
        -- instance of 'Hashable'
        (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Hashable)) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
conC))
        -- declare 'hashWithSalt'
        [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('hashWithSalt)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"s"), Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]]
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('hashWithSalt))
                                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"s")))
                               (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
                [] ] ]

    Dec
d_ix_instance <-
      Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
        -- no context
        Q Cxt
emptyContext
        -- instance of 'Ix'
        (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Data.Ix.Ix)) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
conC))
        -- declare 'range'
        [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('Data.Ix.range)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                [[Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"l"), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"s") ]]
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                  (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                    (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('map)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC))
                    (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                       (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('Data.Ix.range))
                       ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
accV) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"l"))
                             , Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
accV) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"s"))
                             ] ))))
                [] ]

        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('Data.Ix.index)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                [[Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"l"), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"s") ]
                ,Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]
                ]
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                  (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                     (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('Data.Ix.index))
                        ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
accV) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"l"))
                              , Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
accV) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"s"))
                              ] ))
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV) ))
                [] ]
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('Data.Ix.inRange)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                [[Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"l"), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"s") ]
                ,Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]
                ]
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                  (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                     (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                        (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('Data.Ix.inRange))
                        ([Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
accV) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"l"))
                              , Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
accV) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"s"))
                              ] ))
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV) ))
                [] ] ]

    Dec
d_num_instance <-
      Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
        -- no context
        Q Cxt
emptyContext
        -- instance of 'Num'
        (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Num)) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
conC))
        -- declare '(+)'
        [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('(+))
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"x")]
             , Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"y")]
             ]
             -- (+) inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC)
                 (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                   (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('(+)))
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"x")))
                   (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"y")))))
             [] ]
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('(-))
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"x")]
             , Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"y")]
             ]
             -- (+) inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC)
                 (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                   (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('(-)))
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"x")))
                   (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"y")))))
             [] ]
         , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('(*))
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"x")]
             , Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP (String -> Name
mkName String
"y")]
             ]
             -- (+) inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC)
                 (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                   (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('(*)))
                     (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"x")))
                   (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (String -> Name
mkName String
"y")))))
             [] ]
         , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('abs)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]]
             -- show inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC) (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('abs)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))))
             --
             [] ]
         , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('negate)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]]
             -- show inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC)
                 (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('negate)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))))
             --
             [] ]
         , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('signum)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]]
             -- show inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC)
                 (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('signum)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))))
             --
             [] ]
         , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('fromInteger)
           [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
             -- pattern match constructor
             [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]
             -- show inner content
             (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
               (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                 (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC)
                 (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('fromInteger)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))))
             --
             [] ] ]

    Dec
d_arbitrary_instance <-
      Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
        -- no context
        Q Cxt
emptyContext
        -- instance of 'Hashable'
        (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Arbitrary)) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
conC))
        -- declare 'hashWithSalt'
        [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('arbitrary)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                []
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                   (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                         (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('(<$>)))
                         (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC))
                      (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('arbitrary))))
                [] ]
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('shrink)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- pattern match constructor
                [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV]]
                -- show inner content
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                   (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('map)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC))
                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE ('shrink)) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))))
                [] ] ]

    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
      [ Dec
d_newtype
      , Dec
d_show_instance
      , Dec
d_hashable_instance
      , Dec
d_ix_instance
      , Dec
d_num_instance
      , Dec
d_arbitrary_instance
      ]

-----------------------------------------------------------------------------

-- | Creates a basic finite instance using the bounds provided via the
-- first argument, the access function provided by the second argument
-- and the name provided as a string.
--
-- >>> baseInstance [t|Bounds|] [|getBound|] "Example"
-- <BLANKLINE>
-- instance Finite Bounds Example where
--   elements _ = getBound ?bounds
--   value = Example
--   index = example

baseInstance
  :: Q Type -> Q Exp -> String -> Q [Dec]

baseInstance :: Q Pred -> Q Exp -> String -> Q [Dec]
baseInstance Q Pred
bounds Q Exp
f = \case
  []     -> Bool -> Q [Dec] -> Q [Dec]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Q [Dec]
forall a. (?callStack::CallStack) => a
undefined
  (Char
x:String
xr) -> Bool -> Q [Dec] -> Q [Dec]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Char -> Bool
isUpper Char
x) (Q [Dec] -> Q [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ do
    let
      tmpV :: Name
tmpV = String -> Name
mkName String
"x"
      conC :: Name
conC = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xr
      emptyContext :: Q Cxt
emptyContext = [Q Pred] -> Q Cxt
forall (m :: * -> *). Quote m => [m Pred] -> m Cxt
cxt []

    Dec
d_finite_instance <-
      Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
        -- no context
        Q Cxt
emptyContext
        -- instanc of 'Finite'
        (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Finite)) Q Pred
bounds) (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT Name
conC))
        -- declare
        [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('elements)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- ignore the pattern
                [ Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP ]
                -- get the value from the configuartion
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'appBounds) Q Exp
f))
                --
                [] ]
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('value)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- get the value
                [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV ]
                -- apply the constructor
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                  (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                    (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                      (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'assert)
                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                        (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'inRange) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))
                        (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'appBounds) Q Exp
f)))
                    (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
conC) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))))
                --
                [] ]
        , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('index)
            [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
                -- get the value
                [ Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
conC [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV] ]
                -- apply the destructor
                (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
                  (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                    (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                      (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'assert)
                      (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                        (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'inRange) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV))
                        (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'appBounds) Q Exp
f)))
                    (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
                --
                [] ]
        ]

    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Dec
d_finite_instance ]

-----------------------------------------------------------------------------

-- | Combined 'newInstance' with 'baseInstance'.

newBaseInstance
  :: Q Type -> Q Exp -> String -> Q [Dec]

newBaseInstance :: Q Pred -> Q Exp -> String -> Q [Dec]
newBaseInstance Q Pred
bounds Q Exp
f String
name = do
  [Dec]
xs <- String -> Q [Dec]
newInstance String
name
  [Dec]
ys <- Q Pred -> Q Exp -> String -> Q [Dec]
baseInstance Q Pred
bounds Q Exp
f String
name
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
xs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ys

-----------------------------------------------------------------------------

-- | Extends a Finite instance to an extended parameter space. The
-- first argument takes the type to be extended, the second argument
-- the type of the new parameter space and the third argument a
-- translator function that translates the old parameter space into
-- the new one.
--
-- >>> :i Bounds
-- <BLANKLINE>
-- instance Finite Bounds Example
-- <BLANKLINE>
-- >>> :t derive
-- <BLANKLINE>
-- derive :: NewBounds -> Bounds
-- <BLANKLINE>
-- >>> extendInstance [t|Example|] [t|NewBounds] [|translate|]
-- <BLANKLINE>
-- instance Finite NewBounds Example where
--   elements = let ?bounds = translate ?bounds in elements
--   offset = let ?bounds = translate ?bounds in offset
--   value = let ?bounds = translate ?bounds in value
--   index = let ?bounds = translate ?bounds in index

extendInstance
  :: Q Type -> Q Type -> Q Exp -> Q [Dec]

extendInstance :: Q Pred -> Q Pred -> Q Exp -> Q [Dec]
extendInstance Q Pred
rtype Q Pred
bounds Q Exp
access = do
  let tmpV :: Name
tmpV = String -> Name
mkName String
"x"
  Dec
d_finite_instance <-
    Q Cxt -> Q Pred -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Pred -> [m Dec] -> m Dec
instanceD
      -- no context
      ([Q Pred] -> Q Cxt
forall (m :: * -> *). Quote m => [m Pred] -> m Cxt
cxt [])
      -- instanc of 'Finite'
      (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Q Pred -> Q Pred -> Q Pred
forall (m :: * -> *). Quote m => m Pred -> m Pred -> m Pred
appT (Name -> Q Pred
forall (m :: * -> *). Quote m => Name -> m Pred
conT (''Finite)) Q Pred
bounds) Q Pred
rtype)
      -- declare
      [ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('elements)
        [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
          -- ignore the pattern
          [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV ]
          -- get the value from the configuartion
          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
            (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
              (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'elementsSwitch)
                Q Exp
access)
              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
          --
          [] ]
      , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('offset)
        [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
          -- ignore the pattern
          [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV ]
          -- get the value from the configuartion
          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
            (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
              (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'offsetSwitch)
                Q Exp
access)
              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
          --
          [] ]
      , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('value)
        [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
          -- ignore the pattern
          [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV ]
          -- get the value from the configuartion
          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
            (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
              (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'valueSwitch)
                Q Exp
access)
              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
          --
          [] ]
      , Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD ('index)
        [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause
          -- ignore the pattern
          [ Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
tmpV ]
          -- get the value from the configuartion
          (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB
            (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
              (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
                (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'indexSwitch)
                Q Exp
access)
              (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
tmpV)))
          --
          [] ]
        ]
  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
d_finite_instance]

-----------------------------------------------------------------------------

-- | Constructs a polymorph type given a type constructor and a free
-- type variable. Such a construction cannot be expressed in quotation
-- syntax directly.
--
-- >>> polyType [t|Maybe|] "a"
-- <BLANKLINE>
-- Maybe a

polyType
  :: Q Type -> String -> Q Type

polyType :: Q Pred -> String -> Q Pred
polyType Q Pred
con String
str = do
  Pred
t <- Q Pred
con
  Pred -> Q Pred
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pred -> Q Pred) -> Pred -> Q Pred
forall a b. (a -> b) -> a -> b
$ Pred
t Pred -> Pred -> Pred
`AppT` (Name -> Pred
VarT (Name -> Pred) -> Name -> Pred
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
str)

-----------------------------------------------------------------------------

appBounds
  :: FiniteBounds b
  => (b -> a) -> a

appBounds :: forall b a. FiniteBounds b => (b -> a) -> a
appBounds b -> a
x =
  b -> a
x b
FiniteBounds b
?bounds

-----------------------------------------------------------------------------

elementsSwitch
  :: (Finite b' a, FiniteBounds b)
  => (b -> b') -> T a -> Int

elementsSwitch :: forall b' a b.
(Finite b' a, FiniteBounds b) =>
(b -> b') -> T a -> Int
elementsSwitch b -> b'
f =
  let ?bounds = b -> b'
f b
FiniteBounds b
?bounds
  in T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
elements

-----------------------------------------------------------------------------

offsetSwitch
  :: (Finite b' a, FiniteBounds b)
  => (b -> b') -> T a -> Int

offsetSwitch :: forall b' a b.
(Finite b' a, FiniteBounds b) =>
(b -> b') -> T a -> Int
offsetSwitch b -> b'
f =
  let ?bounds = b -> b'
f b
FiniteBounds b
?bounds
  in T a -> Int
forall b a. (Finite b a, FiniteBounds b) => T a -> Int
offset

-----------------------------------------------------------------------------

indexSwitch
  :: (Finite b' a, FiniteBounds b)
  => (b -> b') -> a -> Int

indexSwitch :: forall b' a b.
(Finite b' a, FiniteBounds b) =>
(b -> b') -> a -> Int
indexSwitch b -> b'
f =
  let ?bounds = b -> b'
f b
FiniteBounds b
?bounds
  in a -> Int
forall b a. (Finite b a, FiniteBounds b) => a -> Int
index

-----------------------------------------------------------------------------

valueSwitch
  :: (Finite b' a, FiniteBounds b)
  => (b -> b') -> Int -> a

valueSwitch :: forall b' a b.
(Finite b' a, FiniteBounds b) =>
(b -> b') -> Int -> a
valueSwitch b -> b'
f =
  let ?bounds = b -> b'
f b
FiniteBounds b
?bounds
  in Int -> a
forall b a. (Finite b a, FiniteBounds b) => Int -> a
value

-----------------------------------------------------------------------------

inRange
  :: Int -> Int -> Bool

inRange :: Int -> Int -> Bool
inRange Int
x Int
y =
  Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y

-----------------------------------------------------------------------------