diff --git a/src/Language/Syntactic/Functional.hs b/src/Language/Syntactic/Functional.hs --- a/src/Language/Syntactic/Functional.hs +++ b/src/Language/Syntactic/Functional.hs @@ -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 diff --git a/src/Language/Syntactic/Functional/Tuple.hs b/src/Language/Syntactic/Functional/Tuple.hs --- a/src/Language/Syntactic/Functional/Tuple.hs +++ b/src/Language/Syntactic/Functional/Tuple.hs @@ -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 diff --git a/src/Language/Syntactic/Functional/Tuple/TH.hs b/src/Language/Syntactic/Functional/Tuple/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/Syntactic/Functional/Tuple/TH.hs @@ -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 + diff --git a/src/Language/Syntactic/Sugar/Tuple.hs b/src/Language/Syntactic/Sugar/Tuple.hs --- a/src/Language/Syntactic/Sugar/Tuple.hs +++ b/src/Language/Syntactic/Sugar/Tuple.hs @@ -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 diff --git a/src/Language/Syntactic/Sugar/TupleTyped.hs b/src/Language/Syntactic/Sugar/TupleTyped.hs --- a/src/Language/Syntactic/Sugar/TupleTyped.hs +++ b/src/Language/Syntactic/Sugar/TupleTyped.hs @@ -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 diff --git a/src/Language/Syntactic/TH.hs b/src/Language/Syntactic/TH.hs --- a/src/Language/Syntactic/TH.hs +++ b/src/Language/Syntactic/TH.hs @@ -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 diff --git a/syntactic.cabal b/syntactic.cabal --- a/syntactic.cabal +++ b/syntactic.cabal @@ -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 diff --git a/tests/gold/fib.txt b/tests/gold/fib.txt --- a/tests/gold/fib.txt +++ b/tests/gold/fib.txt @@ -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 diff --git a/tests/gold/spanVec.txt b/tests/gold/spanVec.txt --- a/tests/gold/spanVec.txt +++ b/tests/gold/spanVec.txt @@ -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