syntactic 3.2.1 → 3.3
raw patch · 9 files changed
+365/−220 lines, 9 filesdep +base-orphansdep +syb
Dependencies added: base-orphans, syb
Files
- src/Language/Syntactic/Functional.hs +1/−2
- src/Language/Syntactic/Functional/Tuple.hs +48/−102
- src/Language/Syntactic/Functional/Tuple/TH.hs +239/−0
- src/Language/Syntactic/Sugar/Tuple.hs +5/−44
- src/Language/Syntactic/Sugar/TupleTyped.hs +16/−56
- src/Language/Syntactic/TH.hs +31/−0
- syntactic.cabal +13/−4
- tests/gold/fib.txt +6/−6
- tests/gold/spanVec.txt +6/−6
src/Language/Syntactic/Functional.hs view
@@ -79,8 +79,7 @@ import qualified Data.Set as Set import Data.Tree -import Data.Hash (Hashable, hashInt)-import qualified Data.Hash as Hash+import Data.Hash (hashInt) import Language.Syntactic
src/Language/Syntactic/Functional/Tuple.hs view
@@ -1,11 +1,22 @@+{-# LANGUAGE TemplateHaskell #-}+ -- | Construction and elimination of tuples -module Language.Syntactic.Functional.Tuple where+module Language.Syntactic.Functional.Tuple+ ( module Language.Syntactic.Functional.Tuple+ -- * Template Haskell+ , eqPred+ , classPred+ , mkSelectClassPlusInstances+ , deriveSyntacticForTuples+ ) where import Language.Syntactic+import Language.Syntactic.TH import Language.Syntactic.Functional+import Language.Syntactic.Functional.Tuple.TH @@ -13,70 +24,7 @@ -- * Generic tuple projection -------------------------------------------------------------------------------- -class Select1 tup- where- type Sel1 tup- select1 :: tup -> Sel1 tup--class Select2 tup- where- type Sel2 tup- select2 :: tup -> Sel2 tup--class Select3 tup- where- type Sel3 tup- select3 :: tup -> Sel3 tup--class Select4 tup- where- type Sel4 tup- select4 :: tup -> Sel4 tup--instance Select1 (a,b)- where- type Sel1 (a,b) = a- select1 (a,b) = a--instance Select2 (a,b)- where- type Sel2 (a,b) = b- select2 (a,b) = b--instance Select1 (a,b,c)- where- type Sel1 (a,b,c) = a- select1 (a,b,c) = a--instance Select2 (a,b,c)- where- type Sel2 (a,b,c) = b- select2 (a,b,c) = b--instance Select3 (a,b,c)- where- type Sel3 (a,b,c) = c- select3 (a,b,c) = c--instance Select1 (a,b,c,d)- where- type Sel1 (a,b,c,d) = a- select1 (a,b,c,d) = a--instance Select2 (a,b,c,d)- where- type Sel2 (a,b,c,d) = b- select2 (a,b,c,d) = b--instance Select3 (a,b,c,d)- where- type Sel3 (a,b,c,d) = c- select3 (a,b,c,d) = c--instance Select4 (a,b,c,d)- where- type Sel4 (a,b,c,d) = d- select4 (a,b,c,d) = d+mkSelectClassPlusInstances 15 @@ -85,49 +33,47 @@ -------------------------------------------------------------------------------- -- | Construction and elimination of tuples-data Tuple sig- where- Tup2 :: Tuple (a :-> b :-> Full (a,b))- Tup3 :: Tuple (a :-> b :-> c :-> Full (a,b,c))- Tup4 :: Tuple (a :-> b :-> c :-> d :-> Full (a,b,c,d))- Sel1 :: Select1 tup => Tuple (tup :-> Full (Sel1 tup))- Sel2 :: Select2 tup => Tuple (tup :-> Full (Sel2 tup))- Sel3 :: Select3 tup => Tuple (tup :-> Full (Sel3 tup))- Sel4 :: Select4 tup => Tuple (tup :-> Full (Sel4 tup))--instance Symbol Tuple- where- symSig Tup2 = signature- symSig Tup3 = signature- symSig Tup4 = signature- symSig Sel1 = signature- symSig Sel2 = signature- symSig Sel3 = signature- symSig Sel4 = signature+mkTupleSym "Tuple" "Tup" "Sel" 15 -instance Render Tuple- where- renderSym Tup2 = "tup2"- renderSym Tup3 = "tup3"- renderSym Tup4 = "tup4"- renderSym Sel1 = "sel1"- renderSym Sel2 = "sel2"- renderSym Sel3 = "sel3"- renderSym Sel4 = "sel4"- renderArgs = renderArgsSmart+deriveSymbol ''Tuple+deriveEquality ''Tuple+deriveRender id ''Tuple -instance Equality Tuple instance StringTree Tuple instance Eval Tuple where- evalSym Tup2 = (,)- evalSym Tup3 = (,,)- evalSym Tup4 = (,,,)- evalSym Sel1 = select1- evalSym Sel2 = select2- evalSym Sel3 = select3- evalSym Sel4 = select4+ evalSym Tup2 = (,)+ evalSym Tup3 = (,,)+ evalSym Tup4 = (,,,)+ evalSym Tup5 = (,,,,)+ evalSym Tup6 = (,,,,,)+ evalSym Tup7 = (,,,,,,)+ evalSym Tup8 = (,,,,,,,)+ evalSym Tup9 = (,,,,,,,,)+ evalSym Tup10 = (,,,,,,,,,)+ evalSym Tup11 = (,,,,,,,,,,)+ evalSym Tup12 = (,,,,,,,,,,,)+ evalSym Tup13 = (,,,,,,,,,,,,)+ evalSym Tup14 = (,,,,,,,,,,,,,)+ evalSym Tup15 = (,,,,,,,,,,,,,,)+ evalSym Sel1 = select1+ evalSym Sel2 = select2+ evalSym Sel3 = select3+ evalSym Sel4 = select4+ evalSym Sel5 = select5+ evalSym Sel6 = select6+ evalSym Sel7 = select7+ evalSym Sel8 = select8+ evalSym Sel9 = select9+ evalSym Sel10 = select10+ evalSym Sel11 = select11+ evalSym Sel12 = select12+ evalSym Sel13 = select13+ evalSym Sel14 = select14+ evalSym Sel15 = select15+ -- It would be possible to generate this instance, but the gain would be+ -- small, and it's very hard to get it wrong anyway. instance EvalEnv Tuple env
+ src/Language/Syntactic/Functional/Tuple/TH.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Generate types, classes and instances for tuples++module Language.Syntactic.Functional.Tuple.TH where++++import Data.Generics+import Language.Haskell.TH++import Language.Syntactic ((:->), Full, AST (..), (:<:), Syntactic (..))+import Language.Syntactic.TH++++--------------------------------------------------------------------------------+-- * Generic selection classes and instances+--------------------------------------------------------------------------------++class SelectX tup+ where+ type SelX tup+ selectX :: tup -> SelX tup+ -- Declare the class to be able to quote instances of it++classTemplate :: DecsQ+classTemplate =+ [d| class SelectX tup+ where+ type SelX tup+ selectX :: tup -> SelX tup+ |]++instanceTemplate :: DecsQ+instanceTemplate =+ [d| instance SelectX tup+ where+ type SelX tup = Double+ selectX tup = undefined+ -- Use `Double` and `undefined` as placeholders+ |]++mkSelectClassPlusInstances+ :: Int -- ^ Max tuple width+ -> DecsQ+mkSelectClassPlusInstances n = do+ [classTempl] <- classTemplate+ [instanceTempl] <- instanceTemplate+ let classDecs = [everywhere (mkT (fixName s)) classTempl | s <- [1..n]]+ instDecs =+ [ everywhere+ ( mkT (fixTupType s w)+ . mkT (fixTupPat s w)+ . mkT (fixTupExp s w)+ . mkT (fixName s)+ )+ instanceTempl+ | w <- [2..n]+ , s <- [1..w]+ ]+ return (classDecs ++ instDecs)++-- | @"SelectX_0"@ -> @"Select33"@ (for @n=33@)+fixName :: Int -> Name -> Name+fixName s+ = mkName+ . concatMap (\c -> if c=='X' then show s else [c])+ . takeWhile (/='_')+ . nameBase++fixTupType :: Int -> Int -> Type -> Type+fixTupType s w ty+ | VarT tup <- ty+ , "tup" <- show tup = foldl1 AppT ((TupleT w) : tupVars)+ | ConT doub <- ty+ , show doub == "Double" = tupVars !! (s-1)+ | otherwise = ty+ where+ tupVars = map VarT $ take w varSupply++fixTupPat :: Int -> Int -> Pat -> Pat+fixTupPat s w pat+ | VarP tup <- pat+ , "tup" <- show tup = TupP tupVars+ | otherwise = pat+ where+ tupVars = map VarP $ take w varSupply++fixTupExp :: Int -> Int -> Exp -> Exp+fixTupExp s w ex+ | VarE tup <- ex+ , "tup" <- show tup = TupE tupVars+ | VarE undef <- ex+ , show undef == "undefined" = tupVars !! (s-1)+ | otherwise = ex+ where+ tupVars = map VarE $ take w varSupply++++--------------------------------------------------------------------------------+-- * Symbol type for tuple construction and elimination of tuples+--------------------------------------------------------------------------------++mkTupleSym+ :: String -- ^ Type name+ -> String -- ^ Base name for constructors+ -> String -- ^ Base name for selectors+ -> Int -- ^ Max tuple width+ -> DecsQ+mkTupleSym tyName tupName selName n = do+ let tupCons =+ [ ForallC+ (map PlainTV (take w varSupply))+ [eqPred (VarT (mkName "sig")) (signature w)]+ (NormalC (mkName (tupName ++ show w)) [])+ | w <- [2..n]+ ]+ let selCons =+ [ ForallC+ [PlainTV (mkName "tup")]+ [ eqPred+ (VarT (mkName "sig"))+ ( foldl1 AppT+ [ ConT ''(:->)+ , VarT (mkName "tup")+ , AppT (ConT ''Full) (AppT (ConT (mkName ("Sel" ++ show s))) (VarT (mkName "tup")))+ ]+ )+ , classPred (mkName ("Select" ++ show s)) [VarT (mkName "tup")]+ ]+ (NormalC (mkName (selName ++ show s)) [])+ | s <- [1..n]+ ]+ return [DataD [] (mkName tyName) [PlainTV (mkName "sig")] (tupCons ++ selCons) []]+ where+ signature :: Int -> Type+ signature w = foldr+ (\a res -> foldl1 AppT [ConT ''(:->), a, res])+ (AppT (ConT ''Full)+ (foldl AppT (TupleT w) vars))+ vars+ where+ vars = map VarT $ take w varSupply++++--------------------------------------------------------------------------------+-- * 'Syntactic' instances for tuples+--------------------------------------------------------------------------------++-- Make instances of the form+--+-- > instance+-- > ( Syntactic a+-- > , ...+-- > , Syntactic x+-- >+-- > , internalPred (Internal a)+-- > , ...+-- > , internalPred (Internal x)+-- >+-- > , Tuple :<: sym+-- > , Domain a ~ mkDomain sym+-- >+-- > , Domain a ~ Domain b+-- > , ...+-- > , Domain a ~ Domain x+-- > ) =>+-- > Syntactic (a,...,x)+-- > where+-- > type Domain (a,...,x) = Domain a+-- > type Internal (a,...,x) = (Internal a, ..., Internal x)+-- > desugar (a,...,x) = Sym (symInj TupN) :$ desugar a :$ ... :$ desugar x+-- > sugar tup = (sugar (Sym (symInj Sel1) :$ tup), ..., sugar (Sym (symInj SelN) :$ tup))+deriveSyntacticForTuples+ :: (Type -> Cxt) -- ^ @internalPred@ (see above)+ -> (Type -> Type) -- ^ @mkDomain@ (see above)+ -> (Exp -> Exp) -- ^ Symbol injection+ -> Int -- ^ Max tuple width+ -> DecsQ+deriveSyntacticForTuples internalPred mkDomain symInj n = return $+ map deriveSyntacticForTuple [2..n]+ where+ deriveSyntacticForTuple w = InstanceD+ ( concat+ [ map (classPred ''Syntactic . return) varsT+ , concatMap internalPred $ map (AppT (ConT ''Internal)) varsT+ , [classPred ''(:<:) [ConT (mkName "Tuple"), VarT (mkName "sym")]]+ , [eqPred domainA (mkDomain (VarT (mkName "sym")))]+ , [eqPred domainA (AppT (ConT ''Domain) b)+ | b <- tail varsT+ ]+ ]+ )+ (AppT (ConT ''Syntactic) tupT)+ [ tySynInst ''Domain [tupT] domainA+ , tySynInst ''Internal [tupT] tupTI+ , FunD 'desugar+ [ Clause+ [TupP varsP]+ (NormalB+ ( foldl+ (\s a -> foldl1 AppE [ConE '(:$), s, AppE (VarE 'desugar) a])+ (AppE (ConE 'Sym) (symInj (ConE (mkName ("Tup" ++ show w)))))+ varsE+ )+ )+ []+ ]+ , FunD 'sugar+ [ Clause+ [VarP (mkName "tup")]+ (NormalB+ ( TupE+ [ AppE+ (VarE 'sugar)+ ( foldl1 AppE+ [ ConE '(:$)+ , AppE (ConE 'Sym) (symInj (ConE (mkName ("Sel" ++ show s))))+ , VarE (mkName "tup")+ ]+ )+ | s <- [1..w]+ ]+ )+ )+ []+ ]+ ]+ where+ varsT = map VarT $ take w varSupply+ tupT = foldl AppT (TupleT w) varsT+ tupTI = foldl AppT (TupleT w) $ map (AppT (ConT ''Internal)) varsT+ domainA = AppT (ConT ''Domain) (VarT (mkName "a"))+ varsP = map VarP $ take w varSupply+ varsE = map VarE $ take w varSupply+
src/Language/Syntactic/Sugar/Tuple.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- | 'Syntactic' instances for tuples@@ -6,53 +7,13 @@ +import Language.Haskell.TH+ import Language.Syntactic import Language.Syntactic.Functional.Tuple+import Language.Syntactic.Functional.Tuple.TH -instance- ( Syntactic a- , Syntactic b- , Domain a ~ Domain b- , Tuple :<: Domain a- ) =>- Syntactic (a,b)- where- type Domain (a,b) = Domain a- type Internal (a,b) = (Internal a, Internal b)- desugar (a,b) = sugarSym Tup2 a b- sugar ab = (sugarSym Sel1 ab, sugarSym Sel2 ab)--instance- ( Syntactic a- , Syntactic b- , Syntactic c- , Domain a ~ Domain b- , Domain a ~ Domain c- , Tuple :<: Domain a- ) =>- Syntactic (a,b,c)- where- type Domain (a,b,c) = Domain a- type Internal (a,b,c) = (Internal a, Internal b, Internal c)- desugar (a,b,c) = sugarSym Tup3 a b c- sugar abc = (sugarSym Sel1 abc, sugarSym Sel2 abc, sugarSym Sel3 abc)--instance- ( Syntactic a- , Syntactic b- , Syntactic c- , Syntactic d- , Domain a ~ Domain b- , Domain a ~ Domain c- , Domain a ~ Domain d- , Tuple :<: Domain a- ) =>- Syntactic (a,b,c,d)- where- type Domain (a,b,c,d) = Domain a- type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d)- desugar (a,b,c,d) = sugarSym Tup4 a b c d- sugar abcd = (sugarSym Sel1 abcd, sugarSym Sel2 abcd, sugarSym Sel3 abcd, sugarSym Sel4 abcd)+deriveSyntacticForTuples (const []) id (AppE (VarE 'inj)) 15
src/Language/Syntactic/Sugar/TupleTyped.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -- | 'Syntactic' instances for tuples and 'Typed' symbol domains@@ -7,66 +9,24 @@ import Data.Typeable+import Language.Haskell.TH +#if __GLASGOW_HASKELL__ < 710+import Data.Orphans ()+#endif+ import Language.Syntactic import Language.Syntactic.Functional.Tuple -instance- ( Syntactic a- , Syntactic b- , Typeable (Internal a)- , Typeable (Internal b)- , Domain a ~ Typed sym- , Domain a ~ Domain b- , Tuple :<: sym- ) =>- Syntactic (a,b)- where- type Domain (a,b) = Domain a- type Internal (a,b) = (Internal a, Internal b)- desugar (a,b) = sugarSymTyped Tup2 a b- sugar ab = (sugarSymTyped Sel1 ab, sugarSymTyped Sel2 ab)--instance- ( Syntactic a- , Syntactic b- , Syntactic c- , Typeable (Internal a)- , Typeable (Internal b)- , Typeable (Internal c)- , Domain a ~ Typed sym- , Domain a ~ Domain b- , Domain a ~ Domain c- , Tuple :<: sym- ) =>- Syntactic (a,b,c)- where- type Domain (a,b,c) = Domain a- type Internal (a,b,c) = (Internal a, Internal b, Internal c)- desugar (a,b,c) = sugarSymTyped Tup3 a b c- sugar abc = (sugarSymTyped Sel1 abc, sugarSymTyped Sel2 abc, sugarSymTyped Sel3 abc)--instance- ( Syntactic a- , Syntactic b- , Syntactic c- , Syntactic d- , Typeable (Internal a)- , Typeable (Internal b)- , Typeable (Internal c)- , Typeable (Internal d)- , Domain a ~ Typed sym- , Domain a ~ Domain b- , Domain a ~ Domain c- , Domain a ~ Domain d- , Tuple :<: sym- ) =>- Syntactic (a,b,c,d)- where- type Domain (a,b,c,d) = Domain a- type Internal (a,b,c,d) = (Internal a, Internal b, Internal c, Internal d)- desugar (a,b,c,d) = sugarSymTyped Tup4 a b c d- sugar abcd = (sugarSymTyped Sel1 abcd, sugarSymTyped Sel2 abcd, sugarSymTyped Sel3 abcd, sugarSymTyped Sel4 abcd)+deriveSyntacticForTuples+ (return . classPred ''Typeable . return)+ (AppT (ConT ''Typed))+ (\s -> AppE (ConE 'Typed) (AppE (VarE 'inj) s))+#if __GLASGOW_HASKELL__ < 708+ 7+#else+ 15+#endif
src/Language/Syntactic/TH.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Language.Syntactic.TH where@@ -170,4 +171,34 @@ showArg :: Name -> Exp showArg arg = AppE (VarE 'show) (VarE arg)++++--------------------------------------------------------------------------------+-- * Portability+--------------------------------------------------------------------------------++-- | Portable method for constructing a 'Pred' of the form @(t1 ~ t2)@+eqPred :: Type -> Type -> Pred+#if MIN_VERSION_template_haskell(2,10,0)+eqPred t1 t2 = foldl1 AppT [EqualityT,t1,t2]+#else+eqPred = EqualP+#endif++-- | Portable method for constructing a 'Pred' of the form @SomeClass t1 t2 ...@+classPred :: Name -> [Type] -> Pred+#if MIN_VERSION_template_haskell(2,10,0)+classPred cl = foldl AppT (ConT cl)+#else+classPred = ClassP+#endif++-- | Portable method for constructing a type synonym instances+tySynInst :: Name -> [Type] -> Type -> Dec+#if MIN_VERSION_template_haskell(2,9,0)+tySynInst t as rhs = TySynInstD t (TySynEqn as rhs)+#else+tySynInst = TySynInstD+#endif
syntactic.cabal view
@@ -1,5 +1,5 @@ Name: syntactic-Version: 3.2.1+Version: 3.3 Synopsis: Generic representation and manipulation of abstract syntax Description: The library provides a generic representation of type-indexed abstract syntax trees (or indexed data types in general). It also permits the definition of open syntax@@ -61,18 +61,21 @@ Language.Syntactic.Decoration Language.Syntactic.Functional Language.Syntactic.Functional.Sharing- Language.Syntactic.Functional.Tuple Language.Syntactic.Functional.WellScoped Language.Syntactic.Sugar.Binding Language.Syntactic.Sugar.BindingTyped Language.Syntactic.Sugar.Monad Language.Syntactic.Sugar.MonadTyped- Language.Syntactic.Sugar.Tuple- Language.Syntactic.Sugar.TupleTyped if flag(th) exposed-modules: Language.Syntactic.TH+ Language.Syntactic.Functional.Tuple+ Language.Syntactic.Sugar.Tuple+ Language.Syntactic.Sugar.TupleTyped + other-modules:+ Language.Syntactic.Functional.Tuple.TH+ build-depends: base >= 4 && < 5, constraints,@@ -80,9 +83,15 @@ data-hash, deepseq, mtl >= 2 && < 3,+ syb, tree-view++ if impl(ghc < 7.10)+ build-depends: base-orphans+ if impl(ghc < 7.8) build-depends: tagged+ if flag(th) build-depends: template-haskell
tests/gold/fib.txt view
@@ -1,17 +1,17 @@ Lam v3- └╴sel1+ └╴Sel1 └╴ForLoop ├╴v3- ├╴tup2+ ├╴Tup2 │ ├╴0 │ └╴1 └╴Lam v2 └╴Lam v1- └╴tup2- ├╴sel2+ └╴Tup2+ ├╴Sel2 │ └╴v1 └╴(+)- ├╴sel1+ ├╴Sel1 │ └╴v1- └╴sel2+ └╴Sel2 └╴v1
tests/gold/spanVec.txt view
@@ -3,7 +3,7 @@ ├╴ForLoop │ ├╴arrLen │ │ └╴v3- │ ├╴tup2+ │ ├╴Tup2 │ │ ├╴arrIx │ │ │ ├╴v3 │ │ │ └╴0@@ -12,21 +12,21 @@ │ │ └╴0 │ └╴Lam v2 │ └╴Lam v1- │ └╴tup2+ │ └╴Tup2 │ ├╴min │ │ ├╴arrIx │ │ │ ├╴v3 │ │ │ └╴v2- │ │ └╴sel1+ │ │ └╴Sel1 │ │ └╴v1 │ └╴max │ ├╴arrIx │ │ ├╴v3 │ │ └╴v2- │ └╴sel2+ │ └╴Sel2 │ └╴v1 └╴(-)- ├╴sel2+ ├╴Sel2 │ └╴v4- └╴sel1+ └╴Sel1 └╴v4