-----------------------------------------------------------------------------
-- |
-- 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 :: CxtQ
emptyContext = [PredQ] -> CxtQ
cxt []
      intT :: PredQ
intT = Name -> PredQ
conT (''Int)

    Dec
d_newtype <-
      CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> DecQ
newtypeD
        -- no context
        CxtQ
emptyContext
        -- newtype name
        Name
conC
        -- no type parameters
        []
        -- no kinds
        Maybe Kind
forall a. Maybe a
Nothing
        -- newtype constructor
        (Name -> [VarBangTypeQ] -> ConQ
recC -- normalC
           Name
conC
           [Name -> BangTypeQ -> VarBangTypeQ
varBangType
              Name
accV
              (BangQ -> PredQ -> BangTypeQ
bangType
                (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness)
                PredQ
intT)])
        -- derive 'Eq' and 'Ord'
#if MIN_VERSION_template_haskell(2,12,0)
        [ DerivClause -> DerivClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause
                  Maybe DerivStrategy
forall a. Maybe a
Nothing
                  [ Name -> Kind
ConT (''Eq)
                  , Name -> Kind
ConT (''Ord)
        ])
        ]
#else
        (return [ConT (''Eq), ConT (''Ord)])
#endif

    Dec
d_show_instance <-
      CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
        -- no context
        CxtQ
emptyContext
        -- instance of 'Show'
        (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Show)) (Name -> PredQ
conT Name
conC))
        -- declare 'show'
        [ Name -> [ClauseQ] -> DecQ
funD ('show)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                [Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]]
                -- show inner content
                (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('show)) (Name -> ExpQ
varE Name
tmpV)))
                --
                [] ] ]

    Dec
d_hashable_instance <-
      CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
        -- no context
        CxtQ
emptyContext
        -- instance of 'Hashable'
        (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Hashable)) (Name -> PredQ
conT Name
conC))
        -- declare 'hashWithSalt'
        [ Name -> [ClauseQ] -> DecQ
funD ('hashWithSalt)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                [Name -> PatQ
varP (String -> Name
mkName String
"s"), Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]]
                -- show inner content
                (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('hashWithSalt))
                                     (Name -> ExpQ
varE (String -> Name
mkName String
"s")))
                               (Name -> ExpQ
varE Name
tmpV)))
                [] ] ]

    Dec
d_ix_instance <-
      CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
        -- no context
        CxtQ
emptyContext
        -- instance of 'Ix'
        (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Data.Ix.Ix)) (Name -> PredQ
conT Name
conC))
        -- declare 'range'
        [ Name -> [ClauseQ] -> DecQ
funD ('Data.Ix.range)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                [[PatQ] -> PatQ
tupP [ Name -> PatQ
varP (String -> Name
mkName String
"l"), Name -> PatQ
varP (String -> Name
mkName String
"s") ]]
                -- show inner content
                (ExpQ -> BodyQ
normalB
                  (ExpQ -> ExpQ -> ExpQ
appE
                    (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('map)) (Name -> ExpQ
conE Name
conC))
                    (ExpQ -> ExpQ -> ExpQ
appE
                       (Name -> ExpQ
varE ('Data.Ix.range))
                       ([ExpQ] -> ExpQ
tupE [ ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
accV) (Name -> ExpQ
varE (String -> Name
mkName String
"l"))
                             , ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
accV) (Name -> ExpQ
varE (String -> Name
mkName String
"s"))
                             ] ))))
                [] ]

        , Name -> [ClauseQ] -> DecQ
funD ('Data.Ix.index)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                [[PatQ] -> PatQ
tupP [ Name -> PatQ
varP (String -> Name
mkName String
"l"), Name -> PatQ
varP (String -> Name
mkName String
"s") ]
                ,Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]
                ]
                -- show inner content
                (ExpQ -> BodyQ
normalB
                  (ExpQ -> ExpQ -> ExpQ
appE
                     (ExpQ -> ExpQ -> ExpQ
appE
                        (Name -> ExpQ
varE ('Data.Ix.index))
                        ([ExpQ] -> ExpQ
tupE [ ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
accV) (Name -> ExpQ
varE (String -> Name
mkName String
"l"))
                              , ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
accV) (Name -> ExpQ
varE (String -> Name
mkName String
"s"))
                              ] ))
                     (Name -> ExpQ
varE Name
tmpV) ))
                [] ]
        , Name -> [ClauseQ] -> DecQ
funD ('Data.Ix.inRange)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                [[PatQ] -> PatQ
tupP [ Name -> PatQ
varP (String -> Name
mkName String
"l"), Name -> PatQ
varP (String -> Name
mkName String
"s") ]
                ,Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]
                ]
                -- show inner content
                (ExpQ -> BodyQ
normalB
                  (ExpQ -> ExpQ -> ExpQ
appE
                     (ExpQ -> ExpQ -> ExpQ
appE
                        (Name -> ExpQ
varE ('Data.Ix.inRange))
                        ([ExpQ] -> ExpQ
tupE [ ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
accV) (Name -> ExpQ
varE (String -> Name
mkName String
"l"))
                              , ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
accV) (Name -> ExpQ
varE (String -> Name
mkName String
"s"))
                              ] ))
                     (Name -> ExpQ
varE Name
tmpV) ))
                [] ] ]

    Dec
d_num_instance <-
      CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
        -- no context
        CxtQ
emptyContext
        -- instance of 'Num'
        (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Num)) (Name -> PredQ
conT Name
conC))
        -- declare '(+)'
        [ Name -> [ClauseQ] -> DecQ
funD ('(+))
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [ Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP (String -> Name
mkName String
"x")]
             , Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP (String -> Name
mkName String
"y")]
             ]
             -- (+) inner content
             (ExpQ -> BodyQ
normalB
               (ExpQ -> ExpQ -> ExpQ
appE
                 (Name -> ExpQ
conE Name
conC)
                 (ExpQ -> ExpQ -> ExpQ
appE
                   (ExpQ -> ExpQ -> ExpQ
appE
                     (Name -> ExpQ
varE ('(+)))
                     (Name -> ExpQ
varE (String -> Name
mkName String
"x")))
                   (Name -> ExpQ
varE (String -> Name
mkName String
"y")))))
             [] ]
        , Name -> [ClauseQ] -> DecQ
funD ('(-))
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [ Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP (String -> Name
mkName String
"x")]
             , Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP (String -> Name
mkName String
"y")]
             ]
             -- (+) inner content
             (ExpQ -> BodyQ
normalB
               (ExpQ -> ExpQ -> ExpQ
appE
                 (Name -> ExpQ
conE Name
conC)
                 (ExpQ -> ExpQ -> ExpQ
appE
                   (ExpQ -> ExpQ -> ExpQ
appE
                     (Name -> ExpQ
varE ('(-)))
                     (Name -> ExpQ
varE (String -> Name
mkName String
"x")))
                   (Name -> ExpQ
varE (String -> Name
mkName String
"y")))))
             [] ]
         , Name -> [ClauseQ] -> DecQ
funD ('(*))
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [ Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP (String -> Name
mkName String
"x")]
             , Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP (String -> Name
mkName String
"y")]
             ]
             -- (+) inner content
             (ExpQ -> BodyQ
normalB
               (ExpQ -> ExpQ -> ExpQ
appE
                 (Name -> ExpQ
conE Name
conC)
                 (ExpQ -> ExpQ -> ExpQ
appE
                   (ExpQ -> ExpQ -> ExpQ
appE
                     (Name -> ExpQ
varE ('(*)))
                     (Name -> ExpQ
varE (String -> Name
mkName String
"x")))
                   (Name -> ExpQ
varE (String -> Name
mkName String
"y")))))
             [] ]
         , Name -> [ClauseQ] -> DecQ
funD ('abs)
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]]
             -- show inner content
             (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
conC) (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('abs)) (Name -> ExpQ
varE Name
tmpV))))
             --
             [] ]
         , Name -> [ClauseQ] -> DecQ
funD ('negate)
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]]
             -- show inner content
             (ExpQ -> BodyQ
normalB
               (ExpQ -> ExpQ -> ExpQ
appE
                 (Name -> ExpQ
conE Name
conC)
                 (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('negate)) (Name -> ExpQ
varE Name
tmpV))))
             --
             [] ]
         , Name -> [ClauseQ] -> DecQ
funD ('signum)
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]]
             -- show inner content
             (ExpQ -> BodyQ
normalB
               (ExpQ -> ExpQ -> ExpQ
appE
                 (Name -> ExpQ
conE Name
conC)
                 (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('signum)) (Name -> ExpQ
varE Name
tmpV))))
             --
             [] ]
         , Name -> [ClauseQ] -> DecQ
funD ('fromInteger)
           [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
             -- pattern match constructor
             [Name -> PatQ
varP Name
tmpV]
             -- show inner content
             (ExpQ -> BodyQ
normalB
               (ExpQ -> ExpQ -> ExpQ
appE
                 (Name -> ExpQ
conE Name
conC)
                 (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('fromInteger)) (Name -> ExpQ
varE Name
tmpV))))
             --
             [] ] ]

    Dec
d_arbitrary_instance <-
      CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
        -- no context
        CxtQ
emptyContext
        -- instance of 'Hashable'
        (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Arbitrary)) (Name -> PredQ
conT Name
conC))
        -- declare 'hashWithSalt'
        [ Name -> [ClauseQ] -> DecQ
funD ('arbitrary)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                []
                -- show inner content
                (ExpQ -> BodyQ
normalB
                   (ExpQ -> ExpQ -> ExpQ
appE
                      (ExpQ -> ExpQ -> ExpQ
appE
                         (Name -> ExpQ
varE ('(<$>)))
                         (Name -> ExpQ
conE Name
conC))
                      (Name -> ExpQ
varE ('arbitrary))))
                [] ]
        , Name -> [ClauseQ] -> DecQ
funD ('shrink)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- pattern match constructor
                [Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV]]
                -- show inner content
                (ExpQ -> BodyQ
normalB
                   (ExpQ -> ExpQ -> ExpQ
appE
                      (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('map)) (Name -> ExpQ
conE Name
conC))
                      (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE ('shrink)) (Name -> ExpQ
varE Name
tmpV))))
                [] ] ]

    [Dec] -> Q [Dec]
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 :: PredQ -> ExpQ -> String -> Q [Dec]
baseInstance PredQ
bounds ExpQ
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 :: CxtQ
emptyContext = [PredQ] -> CxtQ
cxt []

    Dec
d_finite_instance <-
      CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
        -- no context
        CxtQ
emptyContext
        -- instanc of 'Finite'
        (PredQ -> PredQ -> PredQ
appT (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Finite)) PredQ
bounds) (Name -> PredQ
conT Name
conC))
        -- declare
        [ Name -> [ClauseQ] -> DecQ
funD ('elements)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- ignore the pattern
                [ PatQ
wildP ]
                -- get the value from the configuartion
                (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'appBounds) ExpQ
f))
                --
                [] ]
        , Name -> [ClauseQ] -> DecQ
funD ('value)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- get the value
                [ Name -> PatQ
varP Name
tmpV ]
                -- apply the constructor
                (ExpQ -> BodyQ
normalB
                  (ExpQ -> ExpQ -> ExpQ
appE
                    (ExpQ -> ExpQ -> ExpQ
appE
                      (Name -> ExpQ
varE 'assert)
                      (ExpQ -> ExpQ -> ExpQ
appE
                        (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'inRange) (Name -> ExpQ
varE Name
tmpV))
                        (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'appBounds) ExpQ
f)))
                    (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
conC) (Name -> ExpQ
varE Name
tmpV))))
                --
                [] ]
        , Name -> [ClauseQ] -> DecQ
funD ('index)
            [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
                -- get the value
                [ Name -> [PatQ] -> PatQ
conP Name
conC [Name -> PatQ
varP Name
tmpV] ]
                -- apply the destructor
                (ExpQ -> BodyQ
normalB
                  (ExpQ -> ExpQ -> ExpQ
appE
                    (ExpQ -> ExpQ -> ExpQ
appE
                      (Name -> ExpQ
varE 'assert)
                      (ExpQ -> ExpQ -> ExpQ
appE
                        (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'inRange) (Name -> ExpQ
varE Name
tmpV))
                        (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE 'appBounds) ExpQ
f)))
                    (Name -> ExpQ
varE Name
tmpV)))
                --
                [] ]
        ]

    [Dec] -> Q [Dec]
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 :: PredQ -> ExpQ -> String -> Q [Dec]
newBaseInstance PredQ
bounds ExpQ
f String
name = do
  [Dec]
xs <- String -> Q [Dec]
newInstance String
name
  [Dec]
ys <- PredQ -> ExpQ -> String -> Q [Dec]
baseInstance PredQ
bounds ExpQ
f String
name
  [Dec] -> Q [Dec]
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 :: PredQ -> PredQ -> ExpQ -> Q [Dec]
extendInstance PredQ
rtype PredQ
bounds ExpQ
access = do
  let tmpV :: Name
tmpV = String -> Name
mkName String
"x"
  Dec
d_finite_instance <-
    CxtQ -> PredQ -> [DecQ] -> DecQ
instanceD
      -- no context
      ([PredQ] -> CxtQ
cxt [])
      -- instanc of 'Finite'
      (PredQ -> PredQ -> PredQ
appT (PredQ -> PredQ -> PredQ
appT (Name -> PredQ
conT (''Finite)) PredQ
bounds) PredQ
rtype)
      -- declare
      [ Name -> [ClauseQ] -> DecQ
funD ('elements)
        [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
          -- ignore the pattern
          [ Name -> PatQ
varP Name
tmpV ]
          -- get the value from the configuartion
          (ExpQ -> BodyQ
normalB
            (ExpQ -> ExpQ -> ExpQ
appE
              (ExpQ -> ExpQ -> ExpQ
appE
                (Name -> ExpQ
varE 'elementsSwitch)
                ExpQ
access)
              (Name -> ExpQ
varE Name
tmpV)))
          --
          [] ]
      , Name -> [ClauseQ] -> DecQ
funD ('offset)
        [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
          -- ignore the pattern
          [ Name -> PatQ
varP Name
tmpV ]
          -- get the value from the configuartion
          (ExpQ -> BodyQ
normalB
            (ExpQ -> ExpQ -> ExpQ
appE
              (ExpQ -> ExpQ -> ExpQ
appE
                (Name -> ExpQ
varE 'offsetSwitch)
                ExpQ
access)
              (Name -> ExpQ
varE Name
tmpV)))
          --
          [] ]
      , Name -> [ClauseQ] -> DecQ
funD ('value)
        [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
          -- ignore the pattern
          [ Name -> PatQ
varP Name
tmpV ]
          -- get the value from the configuartion
          (ExpQ -> BodyQ
normalB
            (ExpQ -> ExpQ -> ExpQ
appE
              (ExpQ -> ExpQ -> ExpQ
appE
                (Name -> ExpQ
varE 'valueSwitch)
                ExpQ
access)
              (Name -> ExpQ
varE Name
tmpV)))
          --
          [] ]
      , Name -> [ClauseQ] -> DecQ
funD ('index)
        [ [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause
          -- ignore the pattern
          [ Name -> PatQ
varP Name
tmpV ]
          -- get the value from the configuartion
          (ExpQ -> BodyQ
normalB
            (ExpQ -> ExpQ -> ExpQ
appE
              (ExpQ -> ExpQ -> ExpQ
appE
                (Name -> ExpQ
varE 'indexSwitch)
                ExpQ
access)
              (Name -> ExpQ
varE Name
tmpV)))
          --
          [] ]
        ]
  [Dec] -> Q [Dec]
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 :: PredQ -> String -> PredQ
polyType PredQ
con String
str = do
  Kind
t <- PredQ
con
  Kind -> PredQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> PredQ) -> Kind -> PredQ
forall a b. (a -> b) -> a -> b
$ Kind
t Kind -> Kind -> Kind
`AppT` (Name -> Kind
VarT (Name -> Kind) -> Name -> Kind
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
str)

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

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

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

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

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

elementsSwitch :: (b -> b') -> T a -> Int
elementsSwitch b -> b'
f =
  let ?bounds = f ?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 :: (b -> b') -> T a -> Int
offsetSwitch b -> b'
f =
  let ?bounds = f ?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 :: (b -> b') -> a -> Int
indexSwitch b -> b'
f =
  let ?bounds = f ?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 :: (b -> b') -> Int -> a
valueSwitch b -> b'
f =
  let ?bounds = f ?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

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