Hi,
meh, I just realised that there is no sensible way to actually
introduce/eliminate the generated types. I'm attaching a revised version with
fromList/toList functions. Maybe the vector type should be polymorphic and be
an instance of Functor, Monad and Foldable? But then we really depend on
specialisation.
Greetings,
Daniel
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS -fglasgow-exts #-}
module TH where
import Language.Haskell.TH
import Control.Monad
-- Non-TH stuff
class InnerProductSpace v r | v -> r where
innerProduct :: v -> v -> r
class AbGroup v where
minus :: v -> v -> v
class FromToList v r | v -> r where
fromList :: [r] -> Maybe v
toList :: v -> [r]
euclidean x y = case minus x y of
z -> sqrt $! innerProduct z z
-- TH
noContext :: Q Cxt
noContext = return []
strict :: Q Type -> StrictTypeQ
strict = liftM ((,) IsStrict)
makeVectors :: Int -- ^ Dimension
-> Q Type -- ^ Component type, assumed to be a 'Num'
-> String -- ^ Name for the generated type
-> Q [Dec]
makeVectors n ctyp name0 = do
-- let's assume ctyp = Double, name = Vector for the comments
-- generate names for the variables we will need
xs <- replicateM n (newName "x")
ys <- replicateM n (newName "y")
lst <- newName "list"
let
name = mkName name0
-- shorthands for arithmetic expressions; the first takes expressions,
-- the others take variable names
sumE e1 e2 = infixE (Just e1) [|(+)|] (Just e2)
varDiffE e1 e2 = infixE (Just (varE e1)) [|(-)|] (Just (varE e2))
varProdE e1 e2 = infixE (Just (varE e1)) [|(*)|] (Just (varE e2))
conPat vars = conP name (fmap varP vars)
-- > data Vector = Vector !Double ... !Double
theDataD =
dataD noContext name [] -- no context, no params
[normalC name (replicate n (strict ctyp))]
[''Eq,''Ord,''Show] -- 'deriving' clause
innerProdD =
-- > instance InnerProductSpace Vector Double where ...
instanceD noContext ( conT ''InnerProductSpace
`appT` conT name
`appT` ctyp)
-- > innerProduct = ...
[valD
(varP 'innerProduct)
(normalB
-- \(Vector x1 x2 ... xn) (Vector y1 y2 ... yn) ->
(lamE [conPat xs, conPat ys]
-- x1*y1 + .... + xn*yn + 0
(foldl sumE [|0|] $
zipWith varProdE xs ys)
))
[] -- no 'where' clause
]
abGroupD =
instanceD noContext ( conT ''AbGroup
`appT` conT name)
-- > minus = ...
[valD
(varP 'minus)
(normalB
-- \(Vector x1 x2 ... xn) (Vector y1 y2 ... yn) ->
(lamE [conPat xs, conPat ys]
-- Vector (x1-y1) ... (xn-yn)
(foldl appE (conE name) $
zipWith varDiffE xs ys)
))
[] -- no 'where' clause
]
fromToListD =
instanceD noContext ( conT ''FromToList
`appT` conT name
`appT` ctyp)
[ funD 'fromList
[ clause [listP $ fmap varP xs]
(normalB
([|Just|] `appE`
(foldl appE (conE name) $ fmap varE xs)))
[]
, clause [wildP] (normalB [|Nothing|]) [] -- wrong number
of elements
]
, funD 'toList
[ clause [conPat xs]
(normalB
(listE (fmap varE xs)))
[]]
]
sequence [theDataD,innerProdD,abGroupD,fromToListD]
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
