syntactic 1.16 → 1.16.1
raw patch · 15 files changed
+76/−70 lines, 15 files
Files
- src/Language/Syntactic/Constraint.hs +38/−18
- src/Language/Syntactic/Constructs/Binding.hs +0/−13
- src/Language/Syntactic/Constructs/Literal.hs +1/−4
- src/Language/Syntactic/Constructs/Tuple.hs +2/−6
- src/Language/Syntactic/Frontend/Tuple.hs +5/−0
- src/Language/Syntactic/Frontend/TupleConstrained.hs +5/−1
- src/Language/Syntactic/Interpretation.hs +3/−6
- src/Language/Syntactic/Interpretation/Equality.hs +2/−3
- src/Language/Syntactic/Interpretation/Evaluation.hs +1/−2
- src/Language/Syntactic/Interpretation/Render.hs +2/−3
- src/Language/Syntactic/Sharing/CodeMotion2.hs +0/−2
- src/Language/Syntactic/Sharing/Graph.hs +1/−3
- src/Language/Syntactic/Sugar.hs +8/−3
- src/Language/Syntactic/Syntax.hs +6/−4
- syntactic.cabal +2/−2
src/Language/Syntactic/Constraint.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ <= 708) {-# LANGUAGE OverlappingInstances #-}+#endif {-# LANGUAGE UndecidableInstances #-} --- TODO Only `InjectC` should be used overlapped. Move to separate module? -- | Type-constrained syntax trees @@ -27,8 +29,9 @@ -- | Intersection of type predicates class (c1 a, c2 a) => (c1 :/\: c2) a-instance (c1 a, c2 a) => (c1 :/\: c2) a where- {-# SPECIALIZE instance (c1 a, c2 a) => (c1 :/\: c2) a #-}+instance (c1 a, c2 a) => (c1 :/\: c2) a+ where+ {-# SPECIALIZE instance (c1 a, c2 a) => (c1 :/\: c2) a #-} infixr 5 :/\: @@ -227,17 +230,19 @@ -- | A version of 'exprDict' that returns a constraint for a particular -- predicate @p@ as long as @(p :< Sat dom)@ holds exprDictSub :: ConstrainedBy expr p => P p -> expr a -> Dict (p (DenResult a))+{-# SPECIALIZE INLINE exprDictSub :: (ConstrainedBy expr p) => P p -> expr a -> Dict (p (DenResult a)) #-} exprDictSub = const $ sub . exprDict-{-# INLINABLE exprDictSub #-} -- | A version of 'exprDict' that works for domains of the form -- @(dom1 :+: dom2)@ as long as @(Sat dom1 ~ Sat dom2)@ holds exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2) => AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a))+{-# SPECIALIZE INLINE+ exprDictPlus :: (Constrained dom1, Constrained dom2, Sat dom1 ~ Sat dom2)+ => AST (dom1 :+: dom2) a -> Dict (Sat dom1 (DenResult a)) #-} exprDictPlus (s :$ _) = exprDictPlus s exprDictPlus (Sym (InjL a)) = exprDict a exprDictPlus (Sym (InjR a)) = exprDict a-{-# INLINABLE exprDictPlus #-} @@ -246,39 +251,59 @@ where injC :: (DenResult sig ~ a) => sub sig -> sup sig -instance (InjectC sub sup a, Sat (AST sup) a) => InjectC sub (AST sup) a+instance (InjectC sub sup a, Sat (AST sup) a) =>+ InjectC sub (AST sup) a where+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) {-# SPECIALIZE instance (InjectC sub sup a, Sat (AST sup) a) => InjectC sub (AST sup) a #-}+#endif+#endif {-# INLINABLE injC #-} injC = Sym . injC -instance (InjectC sub sup a, Sat (sup :| pred) a) => InjectC sub (sup :| pred) a+instance (InjectC sub sup a, Sat (sup :| pred) a) =>+ InjectC sub (sup :| pred) a where {-# SPECIALIZE instance (InjectC sub sup a, Sat (sup :| pred) a) => InjectC sub (sup :| pred) a #-} {-# INLINABLE injC #-} injC = C . injC -instance (InjectC sub sup a, Sat (sup :|| pred) a) => InjectC sub (sup :|| pred) a+instance (InjectC sub sup a, Sat (sup :|| pred) a) =>+ InjectC sub (sup :|| pred) a where+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) {-# SPECIALIZE instance (InjectC sub sup a, Sat (sup :|| pred) a) => InjectC sub (sup :|| pred) a #-}+#endif+#endif {-# INLINABLE injC #-} injC = C' . injC -instance Sat expr a => InjectC expr expr a+instance (Sat expr a) => InjectC expr expr a where- {-# SPECIALIZE instance Sat expr a => InjectC expr expr a #-}+ {-# SPECIALIZE instance (Sat expr a) => InjectC expr expr a #-} {-# INLINABLE injC #-} injC = id -instance InjectC expr1 (expr1 :+: expr2) a+instance {-# OVERLAPPABLE #-} InjectC expr1 (expr1 :+: expr2) a where+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) {-# SPECIALIZE instance InjectC expr1 (expr1 :+: expr2) a #-}+#endif+#endif {-# INLINABLE injC #-} injC = InjL -instance InjectC expr1 expr3 a => InjectC expr1 (expr2 :+: expr3) a+instance {-# OVERLAPPABLE #-} InjectC expr1 expr3 a =>+ InjectC expr1 (expr2 :+: expr3) a where+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) {-# SPECIALIZE instance InjectC expr1 expr3 a => InjectC expr1 (expr2 :+: expr3) a #-}+#endif+#endif {-# INLINABLE injC #-} injC = InjR . injC @@ -466,23 +491,18 @@ instance Constrained Empty where- {-# SPECIALIZE instance Constrained Empty #-} type Sat Empty = Top exprDict = error "Not implemented: exprDict for Empty" instance Equality Empty where- {-# SPECIALIZE instance Equality Empty #-} equal = error "Not implemented: equal for Empty" exprHash = error "Not implemented: exprHash for Empty" instance Eval Empty where- {-# SPECIALIZE instance Eval Empty #-} evaluate = error "Not implemented: equal for Empty" instance Render Empty where- {-# SPECIALIZE instance Render Empty #-} renderSym = error "Not implemented: renderSym for Empty" renderArgs = error "Not implemented: renderArgs for Empty"-instance StringTree Empty where- {-# SPECIALIZE instance StringTree Empty #-}+instance StringTree Empty
src/Language/Syntactic/Constructs/Binding.hs view
@@ -65,7 +65,6 @@ -- @`alphaEq` a b ==> `exprHash` a == `exprHash` b@ instance Equality Variable where- {-# SPECIALIZE instance Equality Variable #-} {-# INLINABLE equal #-} {-# INLINABLE exprHash #-} equal (Variable v1) (Variable v2) = v1==v2@@ -73,13 +72,11 @@ instance Render Variable where- {-# SPECIALIZE instance Render Variable #-} {-# INLINABLE renderSym #-} renderSym (Variable v) = showVar v instance StringTree Variable where- {-# SPECIALIZE instance StringTree Variable #-} {-# INLINABLE stringTreeSym #-} stringTreeSym [] (Variable v) = Node ("var:" ++ show v) [] @@ -96,7 +93,6 @@ instance Constrained Lambda where- {-# SPECIALIZE instance Constrained Lambda #-} {-# INLINABLE exprDict #-} type Sat Lambda = Top exprDict = const Dict@@ -109,7 +105,6 @@ -- @`alphaEq` a b ==> `exprHash` a == `exprHash` b@ instance Equality Lambda where- {-# SPECIALIZE instance Equality Lambda #-} {-# INLINABLE equal #-} {-# INLINABLE exprHash #-} equal (Lambda v1) (Lambda v2) = v1==v2@@ -117,7 +112,6 @@ instance Render Lambda where- {-# SPECIALIZE instance Render Lambda #-} {-# INLINABLE renderSym #-} {-# INLINABLE renderArgs #-} renderSym (Lambda v) = "Lambda " ++ show v@@ -125,7 +119,6 @@ instance StringTree Lambda where- {-# SPECIALIZE instance StringTree Lambda #-} {-# INLINABLE stringTreeSym #-} stringTreeSym [body] (Lambda v) = Node ("Lambda " ++ show v) [body] @@ -150,14 +143,12 @@ instance Constrained Let where- {-# SPECIALIZE instance Constrained Let #-} {-# INLINABLE exprDict #-} type Sat Let = Top exprDict = const Dict instance Equality Let where- {-# SPECIALIZE instance Equality Let #-} {-# INLINABLE equal #-} {-# INLINABLE exprHash #-} equal Let Let = True@@ -165,7 +156,6 @@ instance Render Let where- {-# SPECIALIZE instance Render Let #-} {-# INLINABLE renderSym #-} {-# INLINABLE renderArgs #-} renderSym Let = "Let"@@ -174,7 +164,6 @@ instance StringTree Let where- {-# SPECIALIZE instance StringTree Let #-} {-# INLINABLE stringTreeSym #-} stringTreeSym [a,body] Let = case splitAt 7 node of ("Lambda ", var) -> Node ("Let " ++ var) [a,body']@@ -184,7 +173,6 @@ instance Eval Let where- {-# SPECIALIZE instance Eval Let #-} {-# INLINABLE evaluate #-} evaluate Let = flip ($) @@ -382,7 +370,6 @@ instance VarEqEnv [(VarId,VarId)] where- {-# SPECIALIZE instance VarEqEnv [(VarId,VarId)] #-} {-# INLINABLE prjVarEqEnv #-} {-# INLINABLE modVarEqEnv #-} prjVarEqEnv = id
src/Language/Syntactic/Constructs/Literal.hs view
@@ -25,7 +25,6 @@ instance Equality Literal where- {-# SPECIALIZE instance Equality Literal #-} {-# INLINABLE equal #-} {-# INLINABLE exprHash #-} Literal a `equal` Literal b = case cast a of@@ -36,12 +35,10 @@ instance Render Literal where- {-# SPECIALIZE instance Render Literal #-} {-# INLINABLE renderSym #-} renderSym (Literal a) = show a -instance StringTree Literal where- {-# SPECIALIZE instance StringTree Literal #-}+instance StringTree Literal instance Eval Literal where
src/Language/Syntactic/Constructs/Tuple.hs view
@@ -36,14 +36,12 @@ instance Constrained Tuple where- {-# SPECIALIZE instance Constrained Tuple #-}- {-# INLINE exprDict #-}+ {-# INLINABLE exprDict #-} type Sat Tuple = Top exprDict = const Dict instance Semantic Tuple where- {-# SPECIALIZE instance Semantic Tuple #-} {-# INLINABLE semantics #-} semantics Tup2 = Sem "tup2" (,) semantics Tup3 = Sem "tup3" (,,)@@ -242,14 +240,12 @@ instance Constrained Select where- {-# SPECIALIZE instance Constrained Select #-}- {-# INLINE exprDict #-}+ {-# INLINABLE exprDict #-} type Sat Select = Top exprDict = const Dict instance Semantic Select where- {-# SPECIALIZE instance Semantic Select #-} {-# INLINABLE semantics #-} semantics Sel1 = Sem "sel1" sel1 semantics Sel2 = Sem "sel2" sel2
src/Language/Syntactic/Frontend/Tuple.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} -- | 'Syntactic' instances for Haskell tuples@@ -24,6 +25,8 @@ ) => Syntactic (a,b) where+#ifdef MIN_VERSION_GLASGOW_HASKELL+#if MIN_VERSION_GLASGOW_HASKELL(7,10,2,0) {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom , Syntactic b, Domain b ~ dom , InjectC Tuple dom@@ -33,6 +36,8 @@ , InjectC Select dom (Internal a) , InjectC Select dom (Internal b) ) => Syntactic (a,b) #-}+#endif+#endif {-# INLINABLE desugar #-} {-# INLINABLE sugar #-} type Domain (a,b) = Domain a
src/Language/Syntactic/Frontend/TupleConstrained.hs view
@@ -1,5 +1,9 @@-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-}++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances #-}+#endif -- | Constrained 'Syntactic' instances for Haskell tuples
src/Language/Syntactic/Interpretation.hs view
@@ -14,12 +14,9 @@ semanticInstances :: Name -> DecsQ semanticInstances n = [d|- instance Equality $(typ) where- {-# SPECIALIZE instance Equality $(typ) #-}- instance Render $(typ) where- {-# SPECIALIZE instance Render $(typ) #-}- instance StringTree $(typ) where- {-# SPECIALIZE instance StringTree $(typ) #-}+ instance Equality $(typ)+ instance Render $(typ)+ instance StringTree $(typ) instance Eval $(typ) where {-# SPECIALIZE instance Eval $(typ) #-} |]
src/Language/Syntactic/Interpretation/Equality.hs view
@@ -38,17 +38,16 @@ -- | Default implementation of 'equal' equalDefault :: Semantic expr => expr a -> expr b -> Bool equalDefault a b = equal (semantics a) (semantics b)-{-# INLINE equalDefault #-}+{-# INLINABLE equalDefault #-} -- | Default implementation of 'exprHash' exprHashDefault :: Semantic expr => expr a -> Hash exprHashDefault = exprHash . semantics-{-# INLINE exprHashDefault #-}+{-# INLINABLE exprHashDefault #-} instance Equality Semantics where- {-# SPECIALIZE instance Equality Semantics #-} {-# INLINABLE equal #-} {-# INLINABLE exprHash #-} equal (Sem a _) (Sem b _) = a==b
src/Language/Syntactic/Interpretation/Evaluation.hs view
@@ -21,11 +21,10 @@ -- | Default implementation of 'evaluate' evaluateDefault :: Semantic expr => expr a -> Denotation a evaluateDefault = evaluate . semantics-{-# INLINE evaluateDefault #-}+{-# INLINABLE evaluateDefault #-} instance Eval Semantics where- {-# SPECIALIZE instance Eval Semantics #-} {-# INLINABLE evaluate #-} evaluate (Sem _ a) = a
src/Language/Syntactic/Interpretation/Render.hs view
@@ -42,16 +42,15 @@ -- | Default implementation of 'renderSym' renderSymDefault :: Semantic expr => expr a -> String renderSymDefault = renderSym . semantics-{-# INLINE renderSymDefault #-}+{-# INLINABLE renderSymDefault #-} -- | Default implementation of 'renderArgs' renderArgsDefault :: Semantic expr => [String] -> expr a -> String renderArgsDefault args = renderArgs args . semantics-{-# INLINE renderArgsDefault #-}+{-# INLINABLE renderArgsDefault #-} instance Render Semantics where- {-# SPECIALIZE instance Render Semantics #-} {-# INLINABLE renderSym #-} {-# INLINABLE renderArgs #-} renderSym (Sem name _) = name
src/Language/Syntactic/Sharing/CodeMotion2.hs view
@@ -58,7 +58,6 @@ instance Equality Node where- {-# SPECIALIZE instance Equality Node #-} {-# INLINABLE equal #-} {-# INLINABLE exprHash #-} equal (Node n1) (Node n2) = error "can't compare nodes for equality"@@ -72,7 +71,6 @@ Node :: NodeId -> Node (Full a) instance Render Node where- {-# SPECIALIZE instance Render Node #-} {-# INLINABLE renderSym #-} renderSym (Node n) = showNode n
src/Language/Syntactic/Sharing/Graph.hs view
@@ -52,12 +52,10 @@ instance Render Node where- {-# SPECIALIZE instance Render Node #-} {-# INLINABLE renderSym #-} renderSym (Node a) = showNode a -instance StringTree Node where- {-# SPECIALIZE instance StringTree Node #-}+instance StringTree Node
src/Language/Syntactic/Sugar.hs view
@@ -1,6 +1,10 @@-{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708+{-# LANGUAGE OverlappingInstances #-}+#endif+ -- | \"Syntactic sugar\" module Language.Syntactic.Sugar where@@ -62,7 +66,8 @@ desugarN :: a -> internal sugarN :: internal -> a -instance (Syntactic a, Domain a ~ dom, ia ~ AST dom (Full (Internal a))) => SyntacticN a ia+instance {-# OVERLAPPABLE #-}+ (Syntactic a, Domain a ~ dom, ia ~ AST dom (Full (Internal a))) => SyntacticN a ia where {-# SPECIALIZE instance ( Syntactic a, Domain a ~ dom , ia ~ AST dom (Full (Internal a))@@ -72,7 +77,7 @@ {-# INLINABLE desugarN #-} {-# INLINABLE sugarN #-} -instance+instance {-# OVERLAPPABLE #-} ( Syntactic a , Domain a ~ dom , ia ~ Internal a
src/Language/Syntactic/Syntax.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 708 {-# LANGUAGE OverlappingInstances #-}+#endif {-# LANGUAGE UndecidableInstances #-} -- | Generic representation of typed syntax trees@@ -131,14 +133,14 @@ {-# INLINABLE prj #-} prj = Just -instance Project expr1 (expr1 :+: expr2)+instance {-# OVERLAPPING #-} Project expr1 (expr1 :+: expr2) where {-# SPECIALIZE instance Project expr1 (expr1 :+: expr2) #-} {-# INLINABLE prj #-} prj (InjL a) = Just a prj _ = Nothing -instance Project expr1 expr3 => Project expr1 (expr2 :+: expr3)+instance {-# OVERLAPPING #-} Project expr1 expr3 => Project expr1 (expr2 :+: expr3) where {-# SPECIALIZE instance Project expr1 expr3 => Project expr1 (expr2 :+: expr3) #-} {-# INLINABLE prj #-}@@ -163,13 +165,13 @@ {-# INLINABLE inj #-} inj = id -instance (expr1 :<: (expr1 :+: expr2))+instance {-# OVERLAPPING #-} (expr1 :<: (expr1 :+: expr2)) where {-# SPECIALIZE instance (expr1 :<: (expr1 :+: expr2)) #-} {-# INLINABLE inj #-} inj = InjL -instance (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3))+instance {-# OVERLAPPING #-} (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3)) where {-# SPECIALIZE instance (expr1 :<: expr3) => (expr1 :<: (expr2 :+: expr3)) #-} {-# INLINABLE inj #-}
syntactic.cabal view
@@ -1,5 +1,5 @@ Name: syntactic-Version: 1.16+Version: 1.16.1 Synopsis: Generic abstract syntax, and utilities for embedded languages Description: This library provides: .@@ -51,7 +51,7 @@ Category: Language Build-type: Simple Cabal-version: >=1.10-Tested-with: GHC==7.6.2, GHC==7.8.2+Tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.*, GHC==7.11.* extra-source-files: CONTRIBUTORS