comptrans (empty) → 0.1.0.1
raw patch · 10 files changed
+874/−0 lines, 10 filesdep +basedep +compdatadep +containerssetup-changed
Dependencies added: base, compdata, containers, deepseq, deepseq-generics, ghc-prim, lens, template-haskell, th-expand-syns
Files
- Data/Comp/Derive/Generic.hs +188/−0
- Data/Comp/Trans.hs +133/−0
- Data/Comp/Trans/Collect.hs +69/−0
- Data/Comp/Trans/DeriveMulti.hs +52/−0
- Data/Comp/Trans/DeriveTrans.hs +106/−0
- Data/Comp/Trans/DeriveUntrans.hs +148/−0
- Data/Comp/Trans/Names.hs +77/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- comptrans.cabal +69/−0
+ Data/Comp/Derive/Generic.hs view
@@ -0,0 +1,188 @@+-- |+-- Allows you to derive instances of GHC.Generics for compositional data types.+-- Warning: May slaughter your compile times.++{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- TH runs at compile time, so you get compile-time errors anyway+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- It warns for the instance declarations in TH which are never directly compiled -- GAH++module Data.Comp.Derive.Generic+ (+ makeGeneric+ , makeInstancesLike+ , GenericExample+ ) where++import Control.Lens ( (%~), (&), traversed )+import Control.Monad ( liftM, filterM, mplus, msum )++import qualified Data.Comp.Multi as M+import qualified Data.Comp.Multi.Ops as M++import GHC.Generics ( Generic(..), (:*:)(..), (:+:)(..), K1(..), V1, Rec0, U1(..) )++import Language.Haskell.TH++import Data.Comp.Trans.Names++--------------------------------------------------------------------------------+-- Generic instances for general CDTs+--------------------------------------------------------------------------------++instance (Generic (f e l), Generic (g e l)) => Generic ((f M.:+: g) e l) where+ type Rep ((f M.:+: g) e l) = (Rep (f e l)) :+: (Rep (g e l))+ from = M.caseH (L1 . from) (R1 . from)+ to (L1 x) = M.Inl $ to x+ to (R1 x) = M.Inr $ to x++instance (Generic (f (M.Term f) l)) => Generic (M.Term f l) where+ type Rep (M.Term f l) = Rep (f (M.Term f) l)+ from (M.Term x) = from x+ to x = M.Term $ to x++instance (Generic (f e l)) => Generic ((f M.:&: p) e l) where+ type Rep ((f M.:&: p) e l) = (Rep (f e l)) :*: Rec0 p+ from (t M.:&: x) = from t :*: K1 x+ to (t :*: K1 x) = to t M.:&: x++--------------------------------------------------------------------------------+-- Creating users of Generic+--------------------------------------------------------------------------------++data GenericExample++makeInstancesLike :: [Name] -> [Type] -> Q [Dec] -> Q [Dec]+makeInstancesLike cons labs example = do+ [InstanceD [] (AppT (ConT tc) _) b] <- example+ return [makeInstanceLike tc c l b | c <- cons, l <- labs]++makeInstanceLike :: Name -> Name -> Type -> [Dec] -> Dec+makeInstanceLike tc c l b = InstanceD [] (AppT (ConT tc) (AppT (ConT c) l)) b +++--------------------------------------------------------------------------------+-- Deriving Generic+--------------------------------------------------------------------------------++makeGeneric :: [Name] -> [Type] -> Q [Dec]+makeGeneric nms tps = liftM concat $ sequence [makeGenericInstance n t | n <- nms, t <- tps]++makeGenericInstance :: Name -> Type -> Q [Dec]+makeGenericInstance typNm lab = do+ cons <- liftM simplifyDataInf $ reify typNm+ relCons <- filterM (matchingCon lab . fst) cons+ let mTyp = conT typNm+ let mLab = return lab++ case relCons of+ [] -> [d| instance Generic ($mTyp e $mLab) where+ type Rep ($mTyp e $mLab) = V1+ from = undefined+ to = undefined+ |]++ xs -> do let xts = map snd xs+++ vars1 <- mapM (mapM (const $ newName "x")) xts+ vars2 <- mapM (mapM (const $ newName "x")) xts+ eNm <- case msum $ map (msum.map getEVar) $ map snd xs of+ Just n -> return n+ Nothing -> newName "e"+ + let e = return (VarT eNm)+ let rep = return $ genericTp xts+++ let gPat = addSumPat $ map makeGPat $ vars1+ let gExp = addSumExp $ map makeGExp $ vars2+ let ePat = map makeEPat $ zip xs vars2 & traversed %~ (\((n,_),ns) -> (n, ns))+ let eExp = map makeEExp $ zip xs vars1 & traversed %~ (\((n,_),ns) -> (n, ns))++ inst' <- one [d| instance Generic ($mTyp $e $mLab) where+ type Rep ($mTyp $e $mLab) = $rep+ |]++ addDecs inst' $+ [ FunD 'from (map mkClause $ zip ePat gExp)+ , FunD 'to (map mkClause $ zip gPat eExp)+ ]+ where+ one = liftM head+ addDecs (InstanceD c t ds) ds' = return $ [InstanceD c t (ds++ds')]++ mkClause (pat, expr) = Clause [pat] (NormalB expr) []++ getEVar (AppT (VarT n) _) = Just n+ getEVar (AppT x y ) = getEVar x `mplus` getEVar y+ getEVar _ = Nothing+ ++genericTp :: [[Type]] -> Type+genericTp ts = combine ''(:+:) $ map (combine ''(:*:)) $ map (map (AppT (ConT ''Rec0))) ts+ where+ combine _ [] = ConT ''U1+ combine _ [x] = x+ combine c (x:xs) = AppT (AppT (ConT c) x) (combine c xs)++makeGPat :: [Name] -> Pat+makeGPat [] = ConP 'U1 []+makeGPat [n] = ConP 'K1 [VarP n]+makeGPat (n:ns) = ConP '(:*:) [ ConP 'K1 [VarP n]+ , makeGPat ns + ]++makeGExp :: [Name] -> Exp+makeGExp [] = ConE 'U1+makeGExp [n] = AppE (ConE 'K1) (VarE n)+makeGExp (n:ns) = AppE (AppE (ConE '(:*:)) (AppE (ConE 'K1) (VarE n))) (makeGExp ns) ++makeEPat :: (Name, [Name]) -> Pat+makeEPat (c, ns) = ConP c (map VarP ns)++makeEExp :: (Name, [Name]) -> Exp+makeEExp (c, ns) = foldl AppE (ConE c) (map VarE ns)++addSumPat :: [Pat] -> [Pat]+addSumPat [p] = [p]+addSumPat (p:ps) = [ConP 'L1 [p]] ++ map (\r -> ConP 'R1 [r]) (addSumPat ps)++addSumExp :: [Exp] -> [Exp]+addSumExp [e] = [e]+addSumExp (e:es) = [AppE (ConE 'L1) e] ++ map (\f -> AppE (ConE 'R1) f) (addSumExp es)++matchingCon :: Type -> Name -> Q Bool+matchingCon t nm = do+ (DataConI _ tp parentNm _) <- reify nm+ return $ cxtlessUnifiable (extractLab tp parentNm) t+++extractLab :: Type -> Name -> Type+extractLab tp par = go tp+ where+ go (ForallT _ ctx t) = go $ substCxt ctx t+ go (AppT (AppT (ConT n) _) t)+ | par == n = t+ go (AppT _ t) = go t++ -- My very ghetto way of handling contexts. Found a few+ -- examples where GHC substituted away equality constraints+ -- when getting the type of a data con; assumed it always did,+ -- and now paying the price.+ substCxt [] t = t+ substCxt (EqualP (VarT n) t' : ctx) t = substCxt ctx (tsubst t' n t)+ substCxt (EqualP t' (VarT n) : ctx) t = substCxt ctx (tsubst t' n t)+ substCxt (_ : ctx) t = substCxt ctx t+ + tsubst t n (AppT l r) = AppT (tsubst t n l) (tsubst t n r)+ tsubst t n (VarT n')+ | n == n' = t+ tsubst _ _ x = x+ +cxtlessUnifiable :: Type -> Type -> Bool+cxtlessUnifiable t u | t == u = True+cxtlessUnifiable (VarT _) _ = True+cxtlessUnifiable _ (VarT _) = True+cxtlessUnifiable (AppT t1 u1)+ (AppT t2 u2) = (cxtlessUnifiable t1 t2) && (cxtlessUnifiable u1 u2)+cxtlessUnifiable _ _ = False
+ Data/Comp/Trans.hs view
@@ -0,0 +1,133 @@+-- |+-- +-- GHC has a phase restriction which prevents code generated by Template Haskell+-- being referred to by Template Haskell in the same file. Thus, when using this+-- library, you will need to spread invocations out over several files.+-- +-- We will refer to the following example in the documentation:+-- +-- @+-- module Foo where+-- data Arith = Add Atom Atom+-- data Atom = Var String | Const Lit+-- data Lit = Lit Int+-- @+module Data.Comp.Trans (+ deriveMultiComp+ , generateNameLists+ , makeSumType++ , getLabels++ , T.deriveTrans+ , U.deriveUntrans+ ) where++import Control.Monad ( liftM, mapM )++import Data.Comp.Multi ( (:+:) )+import Data.Data ( Data )++import Language.Haskell.TH.Quote ( dataToExpQ )+import Language.Haskell.TH++import qualified Data.Comp.Trans.DeriveTrans as T+import qualified Data.Comp.Trans.DeriveUntrans as U+import Data.Comp.Trans.DeriveMulti+import Data.Comp.Trans.Collect+import Data.Comp.Trans.Names+++-- |+-- Declares a multi-sorted compositional datatype isomorphic to the+-- given ADT.+-- +-- /e.g./+-- +-- @+-- import qualified Foo as F+-- deriveMultiComp ''F.Arith+-- @+-- +-- will create+-- +-- @+-- data ArithL+-- data AtomL+-- data LitL+-- +-- data Arith e l where+-- Add :: e AtomL -> e AtomL -> Arith e ArithL+-- +-- data Atom e l where+-- Var :: String -> Atom e AtomL+-- Const :: e LitL -> Atom e AtomL+-- +-- data Lit (e :: * -> *) l where+-- Lit :: Int -> Lit e LitL+-- @+deriveMultiComp :: Name -> Q [Dec]+deriveMultiComp root = do descs <- collectTypes root+ liftM concat $ mapM deriveMulti descs++-- |+-- +-- /e.g./+-- +-- @+-- generateNameLists ''Arith+-- @+-- +-- will create+-- +-- @+-- origASTTypes = [mkName "Foo.Arith", mkName "Foo.Atom", mkName "Foo.Lit"]+-- newASTTypes = [mkName "Arith", mkName "Atom", mkName "Lit"]+-- newASTLabels = map ConT [mkName "ArithL", mkName "AtomL', mkName "LitL"]+-- @+generateNameLists :: Name -> Q [Dec]+generateNameLists root = do+ descs <- collectTypes root+ nameList1 <- mkList ''Name (mkName "origASTTypes") descs+ nameList2 <- mkList ''Name (mkName "newASTTypes") (map transName descs)++ return $ nameList1 ++ nameList2+ where++ mkList :: Data t => Name -> Name -> [t] -> Q [Dec]+ mkList tNm name contents = sequence [ sigD name (appT listT (conT tNm))+ , valD (varP name) (normalB namesExp) []+ ]+ where+ namesExp = dataToExpQ (const Nothing) contents++getLabels :: [Name] -> Q [Type]+getLabels nms = mapM toLabel nms+ where+ toLabel n = do TyConI (DataD _ n' _ _ _) <- reify $ nameLab n+ return $ ConT n'++-- |+-- Folds together names with @(`:+:`)@.+-- +-- /e.g./+-- +-- @+-- import qualified Foo as F+-- deriveMult ''F.Arith+-- makeSumType \"ArithSig\" [''Arith, ''Atom, ''Lit]+-- @+-- +-- will create+-- +-- @+-- type ArithSig = Arith :+: Atom :+: Lit+-- @+-- +-- You can use `generateNameLists` to avoid spelling out the names manually+makeSumType :: String -> [Name] -> Q [Dec]+makeSumType nm types = sequence $ [tySynD (mkName nm) [] $ sumType types]+ where+ sumType [] = fail "Attempting to make empty sum type"+ sumType [t] = conT t+ sumType (t:ts) = appT (appT (conT ''(:+:)) (conT t)) (sumType ts)
+ Data/Comp/Trans/Collect.hs view
@@ -0,0 +1,69 @@+module Data.Comp.Trans.Collect (+ collectTypes+ ) where++import Control.Monad ( liftM, liftM2 )++import Data.Foldable ( fold )+import Data.Monoid ( Monoid(..) )++import Data.Set as Set ( Set, singleton, union, difference, toList, member, empty )++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.ExpandSyns ( expandSyns )++import Data.Comp.Trans.Names ( standardNameSet )++-- | Finds all type names transitively referred to by a given type,+-- removing standard types+collectTypes :: Name -> Q [Name]+collectTypes n = do names <- fixpoint collectTypes' n+ return $ toList $ difference names standardNameSet++-- |+-- Finds the fixpoint of a monotone monadic function using chaotic iteration+fixpoint :: (Ord a, Monad m) => (a -> m (Set a)) -> a -> m (Set a)+fixpoint f x = run $ singleton x+ where+ run s = do s' <- liftM fold $ mapSetM f s+ if s' == s then+ return s'+ else+ run s'++-- | mapM for Data.Set+mapSetM :: (Monad m, Ord b) => (a -> m b) -> Set a -> m (Set b)+mapSetM f x = liftM (mconcat . map singleton) $ mapM f (toList x)++collectTypes' :: Name -> Q (Set Name)+collectTypes' n | member n standardNameSet = return empty+collectTypes' n = do inf <- reify n+ let cons = case inf of+ TyConI (DataD _ _ _ cns _) -> cns+ TyConI (NewtypeD _ _ _ con _) -> [con]+ _ -> []+ childNames <- liftM concat $ mapM extractNames cons+ return $ (singleton n) `union` (mconcat $ map singleton childNames)+ ++class ExtractNames a where+ extractNames :: a -> Q [Name]++instance ExtractNames Con where+ extractNames (NormalC _ xs) = liftM concat $ mapM extractNames xs+ extractNames (RecC _ xs) = liftM concat $ mapM extractNames xs+ extractNames (InfixC a _ b) = liftM2 (++) (extractNames a) (extractNames b)+ extractNames (ForallC _ _ x) = extractNames x++instance ExtractNames StrictType where+ extractNames (_, t) = extractNames t++instance ExtractNames VarStrictType where+ extractNames (_, _, t) = extractNames t++instance ExtractNames Type where+ extractNames tSyn = do t <- expandSyns tSyn+ case t of + AppT a b -> liftM2 (++) (extractNames a) (extractNames b)+ ConT n -> return [n]+ _ -> return []
+ Data/Comp/Trans/DeriveMulti.hs view
@@ -0,0 +1,52 @@+module Data.Comp.Trans.DeriveMulti (+ deriveMulti+ ) where++import Control.Lens ( traverse, _1, _2, _3, (&), (%~), (%%~) )+import Control.Monad ( liftM )++import Data.Functor ( (<$>) )++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.ExpandSyns ( expandSyns )++import Data.Comp.Trans.Names ( baseTypes, transName, nameLab, getLab )++deriveMulti :: Name -> Q [Dec]+deriveMulti n = do inf <- reify n+ case inf of+ TyConI (DataD _ nm [] cons _) -> mkGADT nm cons+ TyConI (NewtypeD _ nm [] con _) -> mkGADT nm [con]+ _ -> do reportError $ "Attempted to derive multi-sorted compositional data type for "+ ++ show n ++ ", which is not a nullary datatype"+ return []++mkGADT :: Name -> [Con] -> Q [Dec]+mkGADT n cons = do e <- newName "e"+ i <- newName "i"+ let n' = transName n+ cons' <- mapM (mkCon n' e i) cons+ return $ [DataD [] n' [KindedTV e (AppT (AppT ArrowT StarT) StarT), PlainTV i] cons' []+ ,DataD [] (nameLab n) [] [] []+ ]++mkCon :: Name -> Name -> Name -> Con -> Q Con+mkCon l e i (NormalC n sts) = ForallC [] ctx <$> inner+ where+ ctx = [EqualP (VarT i) (ConT $ nameLab l)]++ sts' = sts & (traverse._2) %%~ unfixType e+ inner = liftM (NormalC (transName n)) sts'+mkCon l e i (RecC n vsts) = ForallC [] ctx <$> inner+ where+ ctx = [EqualP (VarT i) (ConT $ nameLab l)]++ vsts' = vsts & (traverse._1) %~ transName+ vsts'' = vsts' & (traverse._3) %%~ unfixType e+ inner = liftM (RecC (transName n)) vsts''+mkCon _ _ _ c = fail $ "Attempted to derive multi-sorted compositional datatype for something with non-normal constructors: " ++ show c++unfixType :: Name -> Type -> Q Type+unfixType _ t | elem t baseTypes = return t+unfixType e t = do t' <- expandSyns t >>= getLab+ return $ AppT (VarT e) t'
+ Data/Comp/Trans/DeriveTrans.hs view
@@ -0,0 +1,106 @@+module Data.Comp.Trans.DeriveTrans+ (+ deriveTrans+ ) where++import Language.Haskell.TH++import Data.Comp.Trans.Names ( baseTypes, smartConstrName, nameLab, simplifyDataInf )++-- |+-- Creates a functions translating from an ADT+-- to its isomorphic multi-sorted compositional data type+-- +-- @+-- import qualified Foo as F+-- ...+-- type ArithTerm = Term Arith+-- deriveTrans ''Arith [''Arith, ''Atom, ''Lit] ArithTerm+-- @+-- +-- will create+-- +-- @+-- translate :: F.Arith -> ArithTerm ArithL+-- translate = trans+-- +-- +-- class Trans a l where+-- trans a -> ArithTerm l+-- +-- instance Trans F.Arith ArithL where+-- trans (F.Add x y) = iAdd (trans x) (trans y)+-- +-- instance Trans F.Atom AtomL where+-- trans (F.Var s) = iVar s+-- trans (F.Const x) = iConst (trans x)+-- +-- instance Trans F.Lit LitL where+-- trans (F.Lit n) = iLit n+-- @+deriveTrans :: Name -> [Name] -> Type -> Q [Dec]+deriveTrans root names term = do let classNm = mkName "Trans"+ funNm <- newName "trans"++ classDec <- mkClass classNm funNm term+ funDec <- mkFunc root funNm term+ instances <- mapM (mkInstance classNm funNm) names++ return $ [classDec] ++ funDec ++ instances++-- |+-- Example:+-- +-- @+-- translate :: J.CompilationUnit -> JavaTerm CompilationUnitL+-- translate = trans+-- @+mkFunc :: Name -> Name -> Type -> Q [Dec]+mkFunc typ funNm term = return [ SigD translate (AppT (AppT ArrowT (ConT typ)) (AppT term lab))+ , ValD (VarP translate) (NormalB funNm') []+ ]+ where+ translate = mkName "translate"+ lab = ConT $ nameLab typ+ funNm' = VarE funNm++-- |+-- Example:+-- +-- @+-- class Trans a l where+-- trans a -> JavaTerm l+-- @+mkClass :: Name -> Name -> Type -> Q Dec+mkClass classNm funNm term = do a <- newName "a"+ i <- newName "i"+ let transDec = SigD funNm (foldl AppT ArrowT [VarT a, AppT term (VarT i)])+ return $ ClassD [] classNm [PlainTV a, PlainTV i] [] [transDec]++-- |+-- Example:+-- +-- @+-- instance Trans J.CompilationUnit CompilationUnitL where+-- trans (J.CompilationUnit x y z) = iCompilationUnit (trans x) (trans y) (trans z)+-- @+mkInstance :: Name -> Name -> Name -> Q Dec+mkInstance classNm funNm typNm = do inf <- reify typNm+ let nmTyps = simplifyDataInf inf+ clauses <- mapM (uncurry $ mkClause funNm) nmTyps+ let targNm = nameLab typNm+ return (InstanceD []+ (AppT (AppT (ConT classNm) (ConT typNm)) (ConT targNm))+ [FunD funNm clauses])++mkClause :: Name -> Name -> [Type] -> Q Clause+mkClause funNm con tps = do nms <- mapM (const $ newName "x") tps+ return $ Clause [pat nms] (body nms) []+ where+ pat nms = ConP con (map VarP nms)++ body nms = NormalB $ foldl AppE (VarE (smartConstrName con)) (map atom $ zip nms tps)++ atom :: (Name, Type) -> Exp+ atom (x, t) | elem t baseTypes = VarE x+ atom (x, _) = AppE (VarE funNm) (VarE x)
+ Data/Comp/Trans/DeriveUntrans.hs view
@@ -0,0 +1,148 @@+module Data.Comp.Trans.DeriveUntrans (+ deriveUntrans+ ) where++import Control.Monad ( liftM )++import Data.Comp.Multi ( Alg, cata )++import Language.Haskell.TH++import Data.Comp.Trans.Names ( baseTypes, transName, nameLab, simplifyDataInf )++--------------------------------------------------------------------------------+++-- |+-- Creates an @untranslate@ function inverting the @translate@ function+-- created by @deriveTrans@.+-- +-- @+-- import qualified Foo as F+-- type ArithTerm = Term (Arith :+: Atom :+: Lit)+-- deriveUntrans [''F.Arith, ''F.Atom, ''F.Lit] (TH.ConT ''ArithTerm)+-- @+-- +-- will create+-- +-- @+-- type family Targ l+-- newtype T l = T {t :: Targ l}+-- +-- class Untrans f where+-- untrans :: Alg f t+-- +-- untranslate :: ArithTerm l -> Targ l+-- untranslate = t . cata untrans+-- +-- type instance Targ ArithL = F.Arith+-- instance Untrans Arith where+-- untrans (Add x y) = T $ F.Add (t x) (t y)+-- +-- type instance Targ AtomL = F.Atom+-- instance Untrans Atom where+-- untrans (Var s) = T $ F.Var s+-- untrans (Const x) = T $ F.Const (t x)+-- +-- type instance Targ LitL = F.Lit+-- instance Untrans Lit where+-- untrans (Lit n) = T $ F.Lit n+-- @+-- +-- Note that you will need to manually provide an instance @(Untrans f, Untrans g) => Untrans (f :+: g)@+-- due to phase issues.+deriveUntrans :: [Name] -> Type -> Q [Dec]+deriveUntrans names term = do targDec <- mkTarg targNm+ wrapperDec <- mkWrapper wrapNm unwrapNm targNm+ fnDec <- mkFn untranslateNm term targNm unwrapNm fnNm+ classDec <- mkClass classNm fnNm wrapNm+ instances <- liftM concat $ mapM (mkInstance classNm fnNm wrapNm unwrapNm targNm) names+ return $ concat [ targDec+ , wrapperDec+ , fnDec+ , classDec+ , instances+ ]+ where+ targNm = mkName "Targ"+ wrapNm = mkName "T"+ unwrapNm = mkName "t"+ untranslateNm = mkName "untranslate"+ classNm = mkName "Untrans"+ fnNm = mkName "untrans"++{- type family Targ l -}+mkTarg :: Name -> Q [Dec]+mkTarg targNm = do i <- newName "i"+ return [FamilyD TypeFam targNm [PlainTV i] Nothing]++{- newtype T l = T { t :: Targ l } -}+mkWrapper :: Name -> Name -> Name -> Q [Dec]+mkWrapper tpNm fNm targNm = do i <- newName "i"+ let con = RecC tpNm [(fNm, NotStrict, AppT (ConT targNm) (VarT i))]+ return [NewtypeD [] tpNm [PlainTV i] con []]+{-+ untranslate :: JavaTerm l -> Targ l+ untranslate = t . cata untrans+-}+mkFn :: Name -> Type -> Name -> Name -> Name -> Q [Dec]+mkFn fnNm term targNm fldNm untransNm = sequence [sig, def]+ where+ sig = do i <- newName "i"+ sigD fnNm (forallT [PlainTV i] (return []) (typ $ varT i))++ typ :: Q Type -> Q Type+ typ i = [t| $term' $i -> $targ $i |]++ term' = return term+ targ = conT targNm++ def = valD (varP fnNm) (normalB body) []++ body = [| $fld . cata $untrans |]++ fld = varE fldNm+ untrans = varE untransNm++{-+ class Untrans f where+ untrans :: Alg f T+-}+mkClass :: Name -> Name -> Name -> Q [Dec]+mkClass classNm funNm newtpNm = do f <- newName "f"+ let funDec = SigD funNm (AppT (AppT (ConT ''Alg) (VarT f)) (ConT newtpNm))+ return [ClassD [] classNm [PlainTV f] [] [funDec]]+ +{-+ type instance Targ CompilationUnitL = J.CompilationUnit+ instance Untrans CompilationUnit where+ untrans (CompilationUnit x y z) = T $ J.CompilationUnit (t x) (t y) (t z)+-}+mkInstance :: Name -> Name -> Name -> Name -> Name -> Name -> Q [Dec]+mkInstance classNm funNm wrap unwrap targNm typNm = do inf <- reify typNm+ let nmTyps = simplifyDataInf inf+ clauses <- mapM (uncurry $ mkClause wrap unwrap) nmTyps+ return [ famInst+ , inst clauses+ ]+ where+ famInst = TySynInstD targNm (TySynEqn [ConT $ nameLab typNm] (ConT typNm))++ inst clauses = InstanceD []+ (AppT (ConT classNm) (ConT (transName typNm)))+ [FunD funNm clauses]++ ++mkClause :: Name -> Name -> Name -> [Type] -> Q Clause+mkClause wrap unwrap con tps = do nms <- mapM (const $ newName "x") tps+ return $ Clause [pat nms] (body nms) []+ where+ pat nms = ConP (transName con) (map VarP nms)++ body nms = NormalB $ AppE (ConE wrap)+ $ foldl AppE (ConE con) (map atom $ zip nms tps)++ atom :: (Name, Type) -> Exp+ atom (x, t) | elem t baseTypes = VarE x+ atom (x, _) = AppE (VarE unwrap) (VarE x)
+ Data/Comp/Trans/Names.hs view
@@ -0,0 +1,77 @@+module Data.Comp.Trans.Names+ (+ standardNameSet+ , baseTypes+ , getLab+ , transName+ , nameLab+ , smartConstrName+ , modNameBase+ , simplifyDataInf+ ) where++import Control.Lens ( (^.), _3 )+import Control.Monad ( liftM2 )++import Data.Functor ( (<$>) )+import Data.Set ( Set, fromList )++import Language.Haskell.TH.Syntax++{-+ Names that should be excluded from an AST hierarchy.++ Type synonyms need not be present.+-}+standardNameSet :: Set Name+standardNameSet = fromList [''Maybe, ''Int, ''Integer, ''Bool, ''Char, ''Double]+++{-+ Types which should be translated into functorial form.+ + Both String and its expansion are present because+ expandSyn threw errors+ -}+baseTypes :: [Type]+baseTypes = [ ConT ''Int+ , ConT ''Bool+ , ConT ''Char+ , ConT ''Double+ , ConT ''Integer+ , ConT ''String+ , AppT ListT (ConT ''Char)+ ]+++getLab :: Type -> Q Type+getLab (AppT f@(AppT _ _) t) = liftM2 AppT (getLab f) (getLab t)+getLab (AppT f t) = AppT f <$> getLab t+getLab ListT = return ListT+getLab (TupleT n) = return $ TupleT n+getLab (ConT n) = return $ ConT $ nameLab n+getLab _ = fail "When deriving multi-sorted compositional data type, found unsupported type in AST."+++transName :: Name -> Name+transName = modNameBase id++nameLab :: Name -> Name+nameLab = modNameBase (++"L")++smartConstrName :: Name -> Name+smartConstrName = modNameBase ('i':)++modNameBase :: (String -> String) -> Name -> Name+modNameBase f = mkName . f . nameBase++simplifyDataInf :: Info -> [(Name, [Type])]+simplifyDataInf (TyConI (DataD _ _ _ cons _)) = map extractCon cons+simplifyDataInf (TyConI (NewtypeD _ _ _ con _)) = [extractCon con]+simplifyDataInf _ = error "Attempted to derive multi-sorted compositional data type for non-nullary datatype"++extractCon :: Con -> (Name, [Type])+extractCon (NormalC nm sts) = (nm, map snd sts)+extractCon (RecC nm vsts) = (nm, map (^. _3) vsts)+extractCon (ForallC _ _ c) = extractCon c+extractCon _ = error "Unsupported constructor type encountered"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012-2015 James Koppel++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ comptrans.cabal view
@@ -0,0 +1,69 @@+Name: comptrans+Version: 0.1.0.1+Synopsis: +Description: +License: BSD3+License-File: LICENSE+Author: James Koppel+Maintainer: James Koppel+Synopsis: Automatically converting ASTs into compositional data types+Description: + Template Haskell for converting an AST for a language written using normal+ algebraic data types into ones written using multi-sorted compositional data types+ (Data.Comp.Multi from the compdata library) so that you can use generic and modular operators+ on it. You might need to add additional constructors that can e.g.: convert a (Term e Foo) into a+ (Term e [Foo]).+ The source files have comments showing example output for a simple language. See the examples directory+ for an extended example of generating a compositional data type for the entire Java language, with labelled variants+ as well as variants where an entire project of source files can be treated as a single AST -- and you can use the same operations+ on all of them!+Homepage: https://github.com/jkoppel/comptrans+Category: Data,Generics+Build-type: Simple+Cabal-version: >=1.9.2++Source-Repository head+ Type: git+ Location: https://github.com/jkoppel/comptrans++Library++ Extensions:+ DeriveGeneric+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ KindSignatures+ MultiParamTypeClasses+ OverlappingInstances+ TemplateHaskell+ TypeFamilies+ TypeOperators+ TypeSynonymInstances+ UndecidableInstances++ Ghc-Options:+ -Wall++ Exposed-Modules: + Data.Comp.Derive.Generic+ Data.Comp.Trans++ Other-Modules: + Data.Comp.Trans.Collect+ Data.Comp.Trans.DeriveMulti+ Data.Comp.Trans.DeriveTrans+ Data.Comp.Trans.DeriveUntrans+ Data.Comp.Trans.Names++ Build-Depends: base >= 4.7, base < 5+ , compdata < 1+ , containers <= 0.6+ , lens < 5+ , template-haskell+ , th-expand-syns <= 0.4+ , ghc-prim >= 0.2+ , deepseq < 1.4+ , deepseq-generics < 0.1.2