structural-traversal (empty) → 0.1.0.0
raw patch · 9 files changed
+337/−0 lines, 9 filesdep +HUnitdep +basedep +mtlsetup-changed
Dependencies added: HUnit, base, mtl, structural-traversal, template-haskell
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- src/Data/StructuralTraversal.hs +9/−0
- src/Data/StructuralTraversal/Class.hs +10/−0
- src/Data/StructuralTraversal/Indexing.hs +16/−0
- src/Data/StructuralTraversal/Instances.hs +15/−0
- src/Data/StructuralTraversal/TH.hs +140/−0
- structural-traversal.cabal +38/−0
- test/Example.hs +83/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2016, Boldizsár Németh +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 the <organization> nor the + names of its 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 <COPYRIGHT HOLDER> 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
+ src/Data/StructuralTraversal.hs view
@@ -0,0 +1,9 @@+module Data.StructuralTraversal +( module Data.StructuralTraversal.Class +, module Data.StructuralTraversal.Instances +, deriveStructTrav +) where + +import Data.StructuralTraversal.Class +import Data.StructuralTraversal.Instances +import Data.StructuralTraversal.TH
+ src/Data/StructuralTraversal/Class.hs view
@@ -0,0 +1,10 @@+module Data.StructuralTraversal.Class where + +import Control.Applicative + +class StructuralTraversable t where + -- Bottom-up traversal + traverseUp :: Applicative f => f () -> f () -> (a -> f b) -> t a -> f (t b) + + -- Top-down traversal + traverseDown :: Applicative f => f () -> f () -> (a -> f b) -> t a -> f (t b)
+ src/Data/StructuralTraversal/Indexing.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-} +module Data.StructuralTraversal.Indexing where + +import Data.StructuralTraversal.Class +import Control.Monad.State +import Control.Applicative + +indexedTraverse :: StructuralTraversable t => (a -> [Int] -> b) -> t a -> t b +indexedTraverse f + = flip evalState [] + . traverseUp ( modify (0:) ) + ( modify tail ) + ( \a -> f a <$> get <* modify ( \case s:st -> (s+1):st + [] -> [] )) + +
+ src/Data/StructuralTraversal/Instances.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE FlexibleInstances + , UndecidableInstances + , TemplateHaskell + #-} +module Data.StructuralTraversal.Instances where + +import Data.StructuralTraversal.Class +import Control.Applicative +import Data.Traversable +import Data.StructuralTraversal.TH + +deriveStructTrav ''[] +deriveStructTrav ''Maybe +deriveStructTrav ''Either +
+ src/Data/StructuralTraversal/TH.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE LambdaCase + , CPP + , TemplateHaskell + #-} +module Data.StructuralTraversal.TH where + +import Language.Haskell.TH +import Data.StructuralTraversal.Class +import Data.Maybe +import Control.Monad +import Control.Applicative + +-- | Derive SmartTrav +deriveStructTrav :: Name -> Q [Dec] +deriveStructTrav nm = reify nm >>= (\case + TyConI dt -> case dt of + DataD _ tyConName typArgs dataCons _ -> + createInstance tyConName typArgs dataCons + NewtypeD _ tyConName typArgs dataCon _ -> + createInstance tyConName typArgs [dataCon] + _ -> fail "Unsupported data type" + _ -> fail "Expected the name of a data type or newtype" + ) + +createInstance :: Name -> [TyVarBndr] -> [Con] -> Q [Dec] +createInstance tyConName typArgs dataCons + = do (upClauses, preds) <- unzip <$> mapM (createClause upName) dataCons + (downClauses, _) <- unzip <$> mapM (createClause downName) dataCons + return [InstanceD (concat preds) + (AppT (ConT className) + (foldl AppT (ConT tyConName) + (map getTypVarTyp (init typArgs)))) + [FunD upName upClauses, FunD downName downClauses]] + where -- | Gets the variable that is traversed on + varToTraverseOn :: Q Name + varToTraverseOn = case reverse typArgs of + (PlainTV last : _) -> return last + (KindedTV last StarT : _) -> return last + (KindedTV last _ : _) -> fail $ "The kind of the last type parameter is not *" + [] -> fail $ "The kind of type " ++ show tyConName ++ " is *" + + -- | Creates a clause for a constructor, the needed context is also generated + createClause :: Name -> Con -> Q (Clause,[Pred]) + createClause funN (RecC conName conArgs) + = createClause' funN conName (map (\(_,_,r) -> r) conArgs) + createClause funN (NormalC conName conArgs) + = createClause' funN conName (map snd conArgs) + createClause funN (InfixC conArg1 conName conArg2) + = createClause' funN conName [snd conArg1, snd conArg2] + + createClause' :: Name -> Name -> [Type] -> Q (Clause, [Pred]) + createClause' funN conName argTypes + = do bindedNames <- replicateM (length argTypes) (newName "p") + (handleParams,ctx) <- unzip <$> zipWithM (processParam funN) + bindedNames argTypes + return $ (Clause [ VarP desc, VarP asc, VarP f + , ConP conName (map VarP bindedNames) ] + (NormalB (createExpr conName handleParams)) [] + , concat ctx) + + + -- | Creates an expression for the body of a smartTrav clause + -- using the matches created for parameters + createExpr :: Name -> [Exp] -> Exp + createExpr ctrName [] + = AppE applPure $ ConE ctrName + createExpr ctrName (param1:params) + = foldl (\coll new -> InfixE (Just coll) applStar (Just new)) + (InfixE (Just $ ConE ctrName) applDollar (Just param1)) + params + + applStar = VarE (mkName "Control.Applicative.<*>") + applDollar = VarE (mkName "Control.Applicative.<$>") + applPure = VarE (mkName "Control.Applicative.pure") + + className = ''StructuralTraversable + upName = 'traverseUp + downName = 'traverseDown + desc = mkName "desc" + asc = mkName "asc" + f = mkName "f" + + -- | Creates the expression and the predicate for a parameter + processParam :: Name -> Name -> Type -> Q (Exp, [Pred]) + processParam _ name (VarT v) -- found the type variable to traverse on + = do travV <- varToTraverseOn + if v == travV then return (AppE (VarE f) (VarE name), []) + else return (AppE applPure (VarE name), []) + processParam funN name (AppT tf ta) = do + expr <- createExprForHighKind' funN name (VarE f) ta + case expr of Just (e,ctx) -> return (e, if isTypVar tf then createConstraint className tf : ctx + else ctx) + Nothing -> return (AppE applPure (VarE name), []) + processParam _ name _ + = return (AppE applPure (VarE name), []) + + -- | Create an expression and a context for a higher kinded parameter + createExprForHighKind' :: Name -> Name -> Exp -> Type -> Q (Maybe (Exp, [Pred])) + createExprForHighKind' funN name f (AppT tf ta) + = do res <- createExprForHighKind' funN name (applExpr funN f) ta + case res of Just (e,ctx) -> return $ Just (e, if isTypVar tf + then createConstraint className tf : ctx + else ctx) + Nothing -> return Nothing + createExprForHighKind' funN name f (VarT v) + = do travV <- varToTraverseOn + if v == travV then + return $ Just (applExpr funN f `AppE` (VarE name), []) + else return Nothing + createExprForHighKind' _ _ _ _ + = return Nothing + + applExpr funN f = (((VarE funN) `AppE` (VarE desc)) `AppE` (VarE asc)) + `AppE` f + +-- Predicates are types from GHC 7.10 +createConstraint :: Name -> Type -> Pred +createConstraint name typ +#if __GLASGOW_HASKELL__ >= 710 + = AppT (ConT name) typ +#else + = ClassP name [typ] +#endif + + +isTypVar :: Type -> Bool +isTypVar (VarT _) = True +isTypVar _ = False + +getTypVarTyp :: TyVarBndr -> Type +getTypVarTyp (PlainTV n) = VarT n +getTypVarTyp (KindedTV n _) = VarT n + + +thExamine :: Q [Dec] -> Q [Dec] +thExamine decl = do d <- decl + runIO (putStrLn (pprint d)) + return d + +
+ structural-traversal.cabal view
@@ -0,0 +1,38 @@+name: structural-traversal +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: http://github.com/nboldi/structural-traversal#readme +license: BSD3 +license-file: LICENSE +author: Boldizsár Németh +maintainer: nboldi@elte.com +category: Util +build-type: Simple +cabal-version: >=1.10 +source-repository head + type: git + location: http://github.com/nboldi/structural-traversal + +library + hs-source-dirs: ., src + exposed-modules: Data.StructuralTraversal + , Data.StructuralTraversal.Class + , Data.StructuralTraversal.Indexing + , Data.StructuralTraversal.Instances + , Data.StructuralTraversal.TH + build-depends: base >= 4.7 && < 5 + , template-haskell >= 2.9.0.0 + , mtl >= 2.2.1 + default-language: Haskell2010 + +test-suite smart-traversal-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Example.hs + build-depends: base >= 4.7 && < 5 + , HUnit >= 1.2 && < 1.4 + , structural-traversal + , mtl >= 2.2.1 + default-language: Haskell2010 +
+ test/Example.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE StandaloneDeriving, TemplateHaskell, FlexibleContexts, DeriveTraversable #-} + +import Data.StructuralTraversal.Class +import Data.StructuralTraversal.Instances +import Data.StructuralTraversal.TH +import Data.StructuralTraversal.Indexing +import Data.Traversable +import Control.Applicative +import Control.Monad.Writer +import Test.HUnit hiding (test) + +data Name a = Name String + deriving (Show, Eq) + +data Lit a = IntLit Integer + deriving (Show, Eq) + +data Expr a = LitExpr (Lit a) + | Variable (Name a) + | Neg (Ann Expr a) + | Plus (Ann Expr a) (Ann Expr a) + deriving (Show, Eq) + +data Instr a = Assign (Ann Expr a) (Ann Expr a) + | Sequence (AnnList Instr a) + deriving (Show, Eq) + +data Decl a = Procedure (Ann Name a) (Ann Instr a) + deriving (Show, Eq) + +data Ann elem annot + = Ann annot (elem annot) + deriving (Show, Eq) + +instance StructuralTraversable elem => StructuralTraversable (Ann elem) where + traverseUp desc asc f (Ann ann e) = flip Ann <$> (desc *> traverseUp desc asc f e <* asc) <*> f ann + traverseDown desc asc f (Ann ann e) = Ann <$> f ann <*> (desc *> traverseDown desc asc f e <* asc) + +newtype AnnList e a = AnnList { fromAnnList :: [Ann e a] } + deriving (Show, Eq) + +instance StructuralTraversable elem => StructuralTraversable (AnnList elem) where + traverseUp desc asc f (AnnList ls) = AnnList <$> sequenceA (map (traverseUp desc asc f) ls) + traverseDown desc asc f (AnnList ls) = AnnList <$> sequenceA (map (traverseDown desc asc f) ls) + +input = Ann () (Procedure (Ann () (Name "program1")) (Ann () (Sequence (AnnList + [ Ann () (Assign (Ann () (Variable (Name "a"))) (Ann () (LitExpr (IntLit 1)))) + , Ann () (Assign (Ann () (Variable (Name "v"))) (Ann () (Plus (Ann () (Variable (Name "b"))) + (Ann () (LitExpr (IntLit 2)))))) + ])))) + +expected = Ann [] (Procedure (Ann [0] (Name "program1")) (Ann [1] (Sequence (AnnList + [ Ann [0,1] (Assign (Ann [0,0,1] (Variable (Name "a"))) (Ann [1,0,1] (LitExpr (IntLit 1)))) + , Ann [1,1] (Assign (Ann [0,1,1] (Variable (Name "v"))) (Ann [1,1,1] (Plus (Ann [0,1,1,1] (Variable (Name "b"))) + (Ann [1,1,1,1] (LitExpr (IntLit 2)))))) + ])))) + +topDownRes :: [[Int]] +topDownRes = execWriter $ traverseDown (return ()) (return ()) (tell . (:[])) expected + +topDownExpected :: [[Int]] +topDownExpected = [[],[0],[1],[0,1],[0,0,1],[1,0,1],[1,1],[0,1,1],[1,1,1],[0,1,1,1],[1,1,1,1]] + +bottomUpRes :: [[Int]] +bottomUpRes = execWriter $ traverseUp (return ()) (return ()) (tell . (:[])) expected + +bottomUpExpected :: [[Int]] +bottomUpExpected = [[0],[0,0,1],[1,0,1],[0,1],[0,1,1],[0,1,1,1],[1,1,1,1],[1,1,1],[1,1],[1],[]] + +deriveStructTrav ''Lit +deriveStructTrav ''Expr +deriveStructTrav ''Instr +deriveStructTrav ''Decl +deriveStructTrav ''Name + +main :: IO () +main = do assertEqual "The result of the transformation is not as expected" + expected (indexedTraverse (\_ i -> i) input) + assertEqual "The result of bottom-up traversal is not as expected" + bottomUpExpected bottomUpRes + assertEqual "The result of top-down traversal is not as expected" + topDownExpected topDownRes +