[Haskell-cafe] fast Eucl. dist. - Haskell vs C

[Daniel Schüssler]

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
-------------- next part --------------
{-# 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]