Internal.hs

{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE UndecidableInstances #-}

module Math.Module.Internal where

-- base
import Data.Coerce
  ( coerce )
import Data.Monoid
  ( Sum(..) )

-- brush-strokes
import Math.Ring
  ( Ring )
import qualified Math.Ring as Ring
import Math.Linear

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

infixl 6 ^+^, ^-^
infix  9 ^*, *^

class Ring r => Module r m | m -> r where

  {-# MINIMAL origin, (^+^), ( (^*) | (*^) ) #-}

  origin :: m
  (^+^) :: m -> m -> m
  (^-^) :: m -> m -> m
  (*^) :: r -> m -> m
  (^*) :: m -> r -> m

  (*^) = flip (^*)
  (^*) = flip (*^)
  m ^-^ n = m ^+^ Ring.fromInteger ( -1 :: Integer ) *^ n

infixl 8 ^.^

class Module r m => Inner r m where
  (^.^) :: m -> m -> r

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

instance Ring a => Module a ( Sum a ) where

  origin = Sum $ Ring.fromInteger ( 0 :: Integer )

  (^+^) = coerce $ (Ring.+) @a
  (^-^) = coerce $ (Ring.-) @a

  c *^ Sum x = Sum ( c Ring.* x )
  Sum x ^* c = Sum ( x Ring.* c )

deriving via Sum Double instance Module Double ( T Double )

{-
moduleViaRepresentable :: Q TH.Type -> Q TH.Type -> TH.DecsQ
moduleViaRepresentable r m = do
  i <- TH.newName "i"
  let tab b = ( ( TH.varE 'tabulateQ `TH.appTypeE` r ) `TH.appTypeE` m ) `TH.appE` TH.lamE [ TH.varP i ] b
      idx a = ( ( TH.varE 'indexQ `TH.appTypeE` r ) `TH.appTypeE` m ) `TH.appE` TH.varE i

  boo1 <- tab ( TH.varE 'origin `TH.appTypeE` r `TH.appTypeE` m )


  let

      meths =
        [ mkMeth 'origin $ pure boo1 -- $ tab ( TH.varE 'origin `TH.appTypeE` r `TH.appTypeE` m )
        --, mkMeth '(^+^) $ TH.varE '(^+^) `TH.appE` ( TH ) `TH.appE` ()
        ]

  i1 <- TH.instanceD ( pure [] ) ( TH.conT ''Module `TH.appT` r `TH.appT` m ) meths
  return [i1]

  where
    mkMeth nm body = TH.funD nm [ TH.clause [] ( TH.normalB body ) [] ]


moduleViaRepresentable :: ( ( i -> a ) -> TH.CodeQ b ) -> ( b -> i -> TH.CodeQ a ) -> Q TH.Type -> Q TH.Type -> TH.DecsQ
moduleViaRepresentable tab idx r m = do
  [d|
    instance Module $r $m where
       origin  = $( TH.unTypeCode $ tab \ _ -> origin )
       a ^+^ b = $( TH.unTypeCode $ tab \ i -> idx [|| a ||] i ^+^ idx [|| b ||] i )
       a ^-^ b = $( TH.unTypeCode $ tab \ i -> idx [|| a ||] i ^-^ idx [|| b ||] i )
       k *^ a  = $( TH.unTypeCode $ tab \ i -> [|| {- k *^ -} $$( idx [|| a ||] i ) ||] )
    |]
-}