packages feed

derive-IG (empty) → 0.1

raw patch · 8 files changed

+431/−0 lines, 8 filesdep +basedep +instant-genericsdep +template-haskellsetup-changed

Dependencies added: base, instant-generics, template-haskell

Files

+ Generics/Instant/Derive.hs view
@@ -0,0 +1,154 @@+{-# OPTIONS_GHC -fwarn-unused-imports #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, ViewPatterns, FlexibleContexts #-}+module Generics.Instant.Derive +    (derive, deriveCon, deriveConWith, deriveRep, deriveRepWith, deriveWith) where+import Generics.Instant+import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift)+import Control.Monad+import Data.Char (isLower)++normalizeDec :: Dec -> Dec+normalizeDec dec@(DataD _ _ _ _ _)         = dec+normalizeDec (NewtypeD cxt nm vars con xs) = DataD cxt nm vars [con] xs++normalizeCon :: Con -> Con+normalizeCon con@(NormalC _ _)     = con+normalizeCon (RecC name vsts)      = NormalC name $ map (\(n,s,t) -> (s,t)) vsts+normalizeCon (InfixC st1 name st2) = NormalC name [st1, st2]++derives :: [Name] -> Q [Dec]+derives = liftM concat . mapM derive++derive :: Name -> Q [Dec]+derive typName = deriveWith typName []++deriveWith :: Name -> [Maybe String] -> Q [Dec]+deriveWith typName conNames = do+  xs <- deriveConWith' typName conNames+  let consts = concatMap fst xs+      cNames = map (Just . show . snd) xs+  reps <- deriveRepWith typName cNames+  return $ consts ++ reps++consWithNames :: Dec -> [Maybe String] -> [(Con, Name)]+consWithNames (normalizeDec -> DataD _ dName _ cons _) conNames = map step (zip cons conNames)+  where+    step (cons, name) = +        let c@(NormalC cName _) = normalizeCon cons +            altName    = mkName $ replace '.' '_' (show name) ++ "_" ++ nameBase cName+        in (c, maybe altName mkName name)++deriveRep :: Name -> Q [Dec]+deriveRep name = deriveRepWith name (repeat Nothing)++deriveRepWith :: Name -> [Maybe String] -> Q [Dec]+deriveRepWith name conNames = do+  TyConI info <- reify name+  let d@(DataD cxt dName vars cons xs) = normalizeDec info+  inst <- appsT (conT dName) (map (return . bndlToType) vars)+  reps <- forM (consWithNames d conNames) $ \(con, nm) -> do+    let NormalC cName sts   = normalizeCon con+        varOrRec n | n == inst = AppT (ConT ''Rec) n+                   | otherwise = AppT (ConT ''Var) n+        repType | null sts  = return $ ConT ''U+                | otherwise = return $ foldr1 (op ''(:*:)) . map (varOrRec . snd) $ sts+    appT (appT (conT ''C) (conT nm)) repType+  tySyn <- tySynInstD ''Rep [return inst] $ return $ foldr1 (op ''(:+:)) reps+  exps <- buildQ (foldr1 (op ''(:+:)) reps) :: Q [([Name], Exp)]+  pats <- buildQ (foldr1 (op ''(:+:)) reps) :: Q [([Name], Pat)]+  let from = funD (mkName "from") $ zipWith mkFrom cons exps+      to   = funD (mkName "to") $ zipWith mkTo pats cons+  dec <- instanceD (return cxt) (appT (conT ''Representable) (return inst)) [return tySyn, from, to]+  return [dec]+  ++deriveCon :: Name -> Q [Dec]+deriveCon name = deriveConWith name (repeat Nothing)++deriveConWith :: Name -> [Maybe String] -> Q [Dec]+deriveConWith name' conNames = liftM (concatMap fst) $ deriveConWith' name' conNames++deriveConWith' :: Name -> [Maybe String] -> Q [([Dec], Name)]+deriveConWith' name' conNames = do+  TyConI info <- reify name'+  let DataD cxt name vars cons' xs = normalizeDec info+  forM (zip cons' $ conNames ++ repeat Nothing) $ \(conData, aliasName) ->do+    let (cName, args, fixity, isRec) =+          case conData of+            NormalC cName args   -> (cName, args, conE 'Prefix, False)+            RecC cName vsts      -> (cName, map (\(n,s,t) -> (s,t)) vsts, conE 'Prefix, True)+            InfixC st1 cName st2 -> (cName, [st1, st2], appsE [conE 'Infix, conE 'NotAssociative, litE $ integerL 0], False)+        altName    = mkName $ replace '.' '_' (show name) ++ "_" ++ nameBase cName+        conDataName  = maybe altName mkName aliasName+    conDataDec <- dataD (return []) conDataName [] [] []+    cnstrType  <- appT (conT ''C) (conT conDataName)+    conInstDec <- instanceD (return []) (appT (conT ''Constructor) (conT conDataName)) +                        [ funD 'conName [clause [wildP] (normalB (litE $ stringL $ show cName)) []]+                        , funD 'conFixity [clause [wildP] (normalB $  fixity) []]+                        , funD 'conIsRecord [clause [wildP] (normalB $ lift isRec) []]+                        ]+    return ([conDataDec, conInstDec], conDataName)+++bndlToType :: TyVarBndr -> Type+bndlToType (PlainTV nm)    = nameToType nm+bndlToType (KindedTV nm _) = nameToType nm+nameToType name | isLower $ head (nameBase name) = VarT name+                | otherwise                      = ConT name++appsT :: TypeQ -> [TypeQ] -> TypeQ+appsT = foldl appT++replace :: Eq a => a -> a -> [a] -> [a]+replace from to = map step+  where+    step c | c == from = to+           | otherwise = c++op :: Name -> Type -> Type -> Type+op name = AppT . AppT (ConT name)++class Tree a where+    con :: Name -> [a] -> a+    var :: Name -> a++instance Tree Exp where+    con name xs = foldl1 AppE (ConE name:xs)+    var         = VarE++instance Tree Pat where+    con = ConP+    var = VarP++buildQ :: Tree a => Type -> Q [([Name], a)]+buildQ (AppT (AppT (ConT c) _) ty) | c == ''C = do {(nms,bs):_ <- buildQ ty; return [(nms, con 'C [bs])]}+buildQ (AppT (AppT (ConT c) a) b)+    | c == ''(:+:) = do+       (lname,l):_  <- buildQ a+       rs <- buildQ b+       return ((lname, con 'L [l]):map (\(n, exp) -> (n, con 'R [exp])) rs)+    | c == ''(:*:) = do+       ls <- buildQ a+       rs <- buildQ b+       return [(concatMap fst ls ++ concatMap fst rs, con '(:*:) (map snd ls ++ map snd rs))]+buildQ (AppT (ConT c) a)+    | c == ''Var = do+        ((nms, l):_) <- buildQ a+        return [(nms, con 'Var [l])] +    | c == ''Rec = do+        ((nms, r):_) <-buildQ a+        return [(nms, con 'Rec [r])]+buildQ (ConT name) | name == ''U = return [([], con 'U [])]+buildQ v = do+  name <- newName "_param"+  return [([name], var name)]++mkFrom :: Con -> ([Name], Exp) -> ClauseQ+mkFrom (normalizeCon -> NormalC cName _) (names, exp) =+    clause [conP cName (map varP names)] (normalB $ return exp) []++mkTo :: ([Name], Pat) -> Con -> ClauseQ+mkTo (names, pat) (normalizeCon -> NormalC cName _) = +    clause [return pat] (normalB $ appsE (conE cName:map varE names)) []+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Hiromi ISHII++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Hiromi ISHII nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README view
@@ -0,0 +1,9 @@+* Installation+> cabal configure && cabal build && cabal install++* Usage+> import Generics.Instant+> import Generics.Instant.Derive+> +> derive ''Either+> deriveWith ''() [Just "Unit_Unit"]
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ derive-IG.cabal view
@@ -0,0 +1,38 @@+-- derive-IG.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name:                derive-IG++Version:             0.1+Synopsis: Macro to derive instances for Instant-Generics using Template Haskell+Description: Macro to derive instances for Instant-Generics using Template Haskell++Homepage:            http://github.com/konn/derive-IG++License:             BSD3+License-file:        LICENSE+Author:              Hiromi ISHII+Maintainer:          Hiromi ISHII <konn.jinro _at_ gmail.com>++Copyright: (c) 2010 Hiromi ISHII++Category:            Data, Generics++Build-type:          Simple++Cabal-version:       >=1.6++extra-source-files: README example/abstract.hs example/BinEncode.hs example/count.hs+Library+  -- Modules exported by the library.+  Exposed-modules:     Generics.Instant.Derive+  +  Build-depends:       base == 4.*, template-haskell == 2.4.*, instant-generics >= 0.1+  +  -- Modules not exported by this package.+  -- Other-modules:       +  +  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+  -- Build-tools:         +
+ example/BinEncode.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeOperators, TypeFamilies, FlexibleContexts, EmptyDataDecls, TemplateHaskell #-}+module Main where+import Generics.Instant+import Data.List+import DeriveIG++deriveIG ''Either++class Bin a where+    toBin :: a -> [Int]+    fromBin :: [Int] -> (a, [Int])++instance Bin U where+    toBin   U  = []+    fromBin xs = (U, [])++instance (Bin a, Bin b) => Bin (a :+: b) where+    toBin (L a) = 0:toBin a+    toBin (R b) = 1:toBin b+    fromBin (0:bin) = let (a, bin') = fromBin bin in (L a, bin')+    fromBin (1:bin) = let (b, bin') = fromBin bin in (R b, bin')++instance (Bin a, Bin b) => Bin (a :*: b) where+    toBin (a :*: b) = toBin a ++ toBin b+    fromBin bin     =+      let (a, bin')  = fromBin bin+          (b, bin'') = fromBin bin'+      in (a :*: b, bin'')++instance Bin a => Bin (Rec a) where+    toBin (Rec r) = toBin r+    fromBin bin   = let (r, bin') = fromBin bin in (Rec r, bin')++instance Bin a => Bin (C c a) where+    toBin (C a)  = toBin a+    fromBin bin  = let (a, bin') = fromBin bin in (C a, bin')++instance Bin a => Bin (Var a) where+    toBin (Var a) = toBin a+    fromBin bin   = let (x, bin') = fromBin bin in (Var x, bin')++def_toBin :: (Representable a, Bin (Rep a)) => a -> [Int]+def_toBin = toBin . from++def_fromBin :: (Representable a, Bin (Rep a)) => [Int] -> (a, [Int])+def_fromBin bin = let (rep, bin') = fromBin bin in (to rep, bin')+++instance Bin Int where+    toBin i   = let sign   = if i < 0 then 1 else 0+                    i'     = abs i+                    binary = toBits i'+                in take (bitCount + 1) (sign:binary ++ replicate bitCount 0)+    fromBin a = let (s:as, bs) = splitAt (1+bitCount) a+                    sign = [1, -1] !! s+                in (sign*fromBits as, bs)++instance Bin Char where+  toBin      = take 21 . (++replicate 21 0) . toBits . fromEnum+  fromBin bs = let (ch, bs') = splitAt 21 bs in (toEnum $ fromBits ch, bs')++instance Bin a => Bin [a] where { toBin = def_toBin; fromBin = def_fromBin }+instance Bin Bool where { toBin = def_toBin; fromBin = def_fromBin }+instance Bin a => Bin (Maybe a) where { toBin = def_toBin; fromBin = def_fromBin }+instance (Bin a, Bin b) => Bin (Either a b) where { toBin = def_toBin; fromBin = def_fromBin }+instance (Bin a, Bin b) => Bin (a, b) where { toBin = def_toBin; fromBin = def_fromBin }++unfoldrStep :: (b -> Bool) -> (b -> a) -> (b -> b) -> b -> Maybe (a, b)+unfoldrStep p f g x | p x       = Nothing+                    | otherwise = Just (f x, g x)++newtype Wrap a = Wrap {unWrap :: a} deriving (Show, Eq, Ord)++bitCount = ceiling $ logBase 2 $ fromIntegral (maxBound::Int)+toBits   = unfoldr (unfoldrStep (==0) (`mod`2) (`div`2))+fromBits = foldr (\a b -> a+2*b) 0++deriveIG ''Wrap+instance Bin a => Bin (Wrap a) where toBin = def_toBin; fromBin = def_fromBin
+ example/abstract.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TypeOperators, EmptyDataDecls, TypeFamilies, FlexibleContexts, TemplateHaskell #-}+module Main where+import Generics.Instant+import DeriveIG++-- 直に木を舐めるだけの実装+-- everywhere の用に任意の構造体中の木を舐めたければ+-- 各所のコメントを参考にに実装してください+data Expr = Num Int+          | Val String+          | Plus Expr Expr+          | Minus Expr Expr+          | Multi Expr Expr+          | Div   Expr Expr+            deriving (Show, Eq)++deriveIG ''Expr++class Normalize a where+    normalize :: a -> a+    normalize = id++dft_normalize :: (Representable a, Normalize (Rep a)) => a -> a+dft_normalize = to . normalize . from++instance Normalize U++-- 任意の構造中の木を舐める様にするには，Var の中も再帰的に舐める必要がある．+-- 今回は構文木木だけを考えているので，Varの中身は舐めない．+instance Normalize (Var a)++instance (Normalize a, Normalize b) => Normalize (a :+: b) where+    normalize (L a) = L (normalize a)+    normalize (R b) = R (normalize b)++instance (Normalize a, Normalize b) => Normalize (a :*: b) where+    normalize (a :*: b) = normalize a :*: normalize b++instance Normalize a => Normalize (Rec a) where+    normalize (Rec a) = Rec (normalize a)++instance Normalize a => Normalize (C con a) where+    normalize (C a) = C (normalize a)++{- Varの中も舐めるのなら，次の宣言が必要+-- normalize のデフォルト定義が id なので，instance と書くだけでいい+-- instance Normalize Int+-- instance Normalize Char+-- 他のデータ中の木を舐めたければ，次の宣言も追加+-- instance Normalzie a => Normalize (Maybe a) where normalize = dft_normalize+-- instance Normalzie a => Normalize [a] where normalize = dft_normalize+-- etc, etc...+-}++instance Normalize Expr where+  normalize x = case dft_normalize x of+                  Plus (Num n) (Num m)  -> Num (n + m)+                  Multi (Num n) (Num m) -> Num (n * m)+                  Minus (Num n) (Num m) -> Num(n - m)+                  Div (Num n) (Num m)   -> Num(n `div` m)+                  x                     -> x++-- 2 * (3 + 2 * 5) = 26+tree1 = Multi (Num 2) (Plus (Num 3) (Multi (Num 2) (Num 5)))++-- a * (3 + 2 * 5) = a * 13+tree2 = Multi (Val "a") (Plus (Num 3) (Multi (Num 2) (Num 5)))++tree3 = Multi (Multi (Num 2) (Plus (Num 5) (Num 2))) tree2
+ example/count.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, FlexibleContexts, OverlappingInstances #-}+{-# LANGUAGE FlexibleInstances ,TypeSynonymInstances, TypeFamilies, TypeOperators #-}+module Main where+import Generics.Instant+import Language.Haskell.TH+import Generics.Instant.Derive++data Expr = N Int+          | V String+          | P Expr Expr+            deriving (Show, Eq, Ord)++derive ''Expr+deriveWith ''(,,) [Just "Triple_Con"]+deriveWith ''()   [Just "Unit_Unit"]+++class Count a where+    count :: a -> Int+    count _ = 1++instance Count Int+instance Count Char+instance Count Bool+instance Count String++instance Count U+instance Count (C con U)+instance Count a => Count (Var a) where+    count (Var a) = count a+instance (Count a, Count b) => Count (a :*: b) where+    count (a :*: b) = count a + count b+instance (Count a) => Count (Rec a) where+    count (Rec a) = count a+instance Count a => Count (C con a) where+    count (C a) = 1 + count a+instance (Count a, Count b) => Count (a :+: b) where+    count (L a) = count a+    count (R b) = count b++dft_count :: (Representable a, Count (Rep a)) => a -> Int+dft_count = count . from++instance Count () where count = dft_count+instance Count a => Count (Maybe a) where count = dft_count+instance Count a => Count [a] where count = dft_count+instance (Count a, Count b) => Count (a, b) where count = dft_count+instance (Count a, Count b, Count c) => Count (a, b, c) where count = dft_count+instance Count Expr where count = dft_count+