Skip to content

Commit 67f5409

Browse files
phischuphischu
authored
Merge pull request #82 from phischu/pattern_synonyms
Pattern synonyms again.
2 parents f2581ac + 7cab7b7 commit 67f5409

File tree

10 files changed

+259
-98
lines changed

10 files changed

+259
-98
lines changed

‎src/Language/Haskell/Names/Environment.hs‎

Lines changed: 14 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,6 +70,11 @@ instance ToJSON Symbol where
7070
["associate" .= fmap prettyName as]
7171
DataFam { associate = as } ->
7272
["associate" .= fmap prettyName as]
73+
PatternConstructor { patternTypeName = mty } ->
74+
["patternTypeName" .= fmap prettyName mty]
75+
PatternSelector { patternTypeName = mty, patternConstructorName = pn } ->
76+
["patternTypeName" .= fmap prettyName mty
77+
,"patternConstructorName" .= prettyName pn]
7378
_ -> []
7479

7580
symbolEntity :: Symbol -> String
@@ -84,7 +89,8 @@ symbolEntity i = case i of
8489
TypeFam {} -> "typeFamily"
8590
DataFam {} -> "dataFamily"
8691
Class {} -> "class"
87-
PatSyn {} -> "patSyn"
92+
PatternConstructor {} -> "patternConstructor"
93+
PatternSelector {} -> "patternSelector"
8894

8995
parseName :: String -> Name ()
9096
parseName = dropAnn . stringToName
@@ -117,7 +123,13 @@ instance FromJSON Symbol where
117123
associate <- fmap parseName <$> v .: "associate"
118124
return $ DataFam symbolmodule symbolname associate
119125
"class" -> return $ Class symbolmodule symbolname
120-
"patSyn" -> return $ PatSyn symbolmodule symbolname
126+
"patternConstructor" -> do
127+
typ <- fmap parseName <$> v .: "patternTypeName"
128+
return (PatternConstructor symbolmodule symbolname typ)
129+
"patternSelector" -> do
130+
typ <- fmap parseName <$> v .: "patternTypeName"
131+
patternname <- parseName <$> v .: "patternConstructorName"
132+
return (PatternSelector symbolmodule symbolname typ patternname)
121133
_ -> mzero
122134

123135
parseJSON _ = mzero

‎src/Language/Haskell/Names/Exports.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@ import Control.Applicative
1010
import Control.Monad
1111
import Control.Monad.Writer
1212
import Data.Data
13-
import Language.Haskell.Exts hiding (PatSyn)
13+
import Language.Haskell.Exts
1414
import Language.Haskell.Names.Types
1515
import Language.Haskell.Names.ScopeUtils
1616
import Language.Haskell.Names.SyntaxUtils
@@ -51,15 +51,16 @@ annotateExportSpec globalTable exportSpec =
5151
[symbol] -> EVar (Scoped (Export [symbol]) l)
5252
(Scoped (GlobalSymbol symbol (dropAnn qn)) <$> qn)
5353
symbols -> scopeError (EAmbiguous qn symbols) exportSpec
54+
EAbs l ns@(PatternNamespace _) qn ->
55+
case Global.lookupValue qn globalTable of
56+
[] -> scopeError (ENotInScope qn) exportSpec
57+
[symbol] -> EAbs (Scoped (Export [symbol]) l)
58+
(noScope ns)
59+
(Scoped (GlobalSymbol symbol (dropAnn qn)) <$> qn)
60+
symbols -> scopeError (EAmbiguous qn symbols) exportSpec
5461
EAbs l ns qn ->
5562
case Global.lookupType qn globalTable of
5663
[] -> scopeError (ENotInScope qn) exportSpec
57-
[symbol@(PatSyn _ _)] -> case Global.lookupValue qn globalTable of
58-
[] -> scopeError (ENotInScope qn) exportSpec
59-
[patCtor] -> EAbs (Scoped (Export [symbol, patCtor]) l)
60-
(noScope ns)
61-
(Scoped (GlobalSymbol symbol (dropAnn qn)) <$> qn)
62-
symbols -> scopeError (EAmbiguous qn symbols) exportSpec
6364
[symbol] -> EAbs (Scoped (Export [symbol]) l)
6465
(noScope ns)
6566
(Scoped (GlobalSymbol symbol (dropAnn qn)) <$> qn)

‎src/Language/Haskell/Names/GlobalSymbolTable.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,8 @@ isValue symbol = case symbol of
4545
Method {} -> True
4646
Selector {} -> True
4747
Constructor {} -> True
48+
PatternConstructor {} -> True
49+
PatternSelector {} -> True
4850
_ -> False
4951

5052
isType :: Symbol -> Bool
@@ -55,7 +57,6 @@ isType symbol = case symbol of
5557
TypeFam {} -> True
5658
DataFam {} -> True
5759
Class {} -> True
58-
PatSyn {} -> True
5960
_ -> False
6061

6162
isMethodOrAssociated :: Symbol -> Bool

‎src/Language/Haskell/Names/ModuleSymbols.hs‎

Lines changed: 23 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -8,11 +8,10 @@ module Language.Haskell.Names.ModuleSymbols
88

99
import Data.Maybe
1010
import Data.Data
11-
import Data.Generics.Uniplate.Operations (transform, universe)
1211
import qualified Data.Map as Map
1312

14-
import Language.Haskell.Exts hiding (DataOrNew(NewType), PatSyn)
15-
import qualified Language.Haskell.Exts as Syntax (DataOrNew(NewType), Decl(PatSyn))
13+
import Language.Haskell.Exts hiding (DataOrNew(NewType))
14+
import qualified Language.Haskell.Exts as Syntax (DataOrNew(NewType))
1615
import Language.Haskell.Names.Types
1716
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
1817
import Language.Haskell.Names.SyntaxUtils
@@ -91,31 +90,11 @@ getTopDeclSymbols impTbl modulename d = (case d of
9190

9291
PatBind _ p _ _ -> [ Value (dropAnn modulename) (dropAnn vn) | vn <- getBound impTbl p ]
9392

94-
Syntax.PatSyn _ p _ _ -> fromMaybe [] $ do
95-
patSyn <- listToMaybe [ PatSyn (dropAnn modulename) (dropAnn vn) | p' <- universe $ transform dropFields $ transform dropExp p, UnQual _ vn <- varp p' ]
96-
let
97-
patName = symbolName patSyn
98-
patCtor = Constructor (symbolModule patSyn) patName patName
99-
fields = [ Selector (symbolModule patSyn) (dropAnn vn) patName [patName] | p' <- universe $ transform dropExp p, UnQual _ vn <- vfield p' ]
100-
return (patSyn : patCtor : fields)
101-
102-
where
103-
varp (PApp _ q _) = [q]
104-
varp (PInfixApp _ _ q _) = [q]
105-
varp (PRec _ q _) = [q]
106-
varp _ = []
107-
108-
vfield (PRec _ _ fs) = concatMap get' fs where
109-
get' (PFieldPat _ q _) = [q]
110-
get' (PFieldPun _ q) = [q]
111-
get' _ = []
112-
vfield _ = []
113-
114-
dropExp (PViewPat _ _ x) = x
115-
dropExp x = x
116-
117-
dropFields (PRec l q _) = PRec l q []
118-
dropFields x = x
93+
PatSyn _ p _ _ -> case patternHead p of
94+
Just patternName -> patternConstructor : patternSelectors where
95+
patternConstructor = PatternConstructor (dropAnn modulename) (dropAnn patternName) Nothing
96+
patternSelectors = [PatternSelector (dropAnn modulename) (dropAnn fn) Nothing (dropAnn patternName) | fn <- patternFields p ]
97+
Nothing -> []
11998

12099
ForImp _ _ _ _ fn _ -> [ Value (dropAnn modulename) (dropAnn fn)]
121100

@@ -174,3 +153,19 @@ qualConDeclNames qualConDecls = do
174153

175154
dataOrNewCon :: Syntax.DataOrNew l -> ModuleName () -> Name () -> Symbol
176155
dataOrNewCon dataOrNew = case dataOrNew of DataType {} -> Data; Syntax.NewType {} -> NewType
156+
157+
158+
patternHead :: Pat l -> Maybe (Name l)
159+
patternHead (PApp _ (UnQual _ n) _) = Just n
160+
patternHead (PInfixApp _ _ (UnQual _ n) _) = Just n
161+
patternHead (PRec _ (UnQual _ n) _) = Just n
162+
patternHead _ = Nothing
163+
164+
165+
patternFields :: Pat l -> [Name l]
166+
patternFields (PRec _ _ fs) = concatMap get' fs where
167+
get' (PFieldPat _ (UnQual _ n) _) = [n]
168+
get' (PFieldPun _ (UnQual _ n)) = [n]
169+
get' _ = []
170+
patternFields _ = []
171+

‎src/Language/Haskell/Names/Open/Instances.hs‎

Lines changed: 2 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -10,7 +10,7 @@
1010

1111
module Language.Haskell.Names.Open.Instances where
1212

13-
import Language.Haskell.Names.Types hiding (PatSyn)
13+
import Language.Haskell.Names.Types
1414
import Language.Haskell.Names.Open.Base
1515
import Language.Haskell.Names.Open.Derived ()
1616
import Language.Haskell.Names.GetBound
@@ -19,14 +19,12 @@ import Language.Haskell.Exts
1919
import Language.Haskell.Names.SyntaxUtils
2020
import qualified Data.Data as D
2121
import Control.Applicative
22-
import Data.Generics.Traversable
2322
import Data.Typeable
2423
import Data.Type.Equality
2524
import Data.Lens.Light
2625
import Data.List
2726
import qualified Data.Traversable as T
2827

29-
import Debug.Trace
3028

3129
c :: Applicative w => c -> w c
3230
c = pure
@@ -90,37 +88,7 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Decl l) where
9088
<| sc' -: rule
9189
<| sc' -: mInstDecls
9290
_ -> defaultRtraverse e sc
93-
where
94-
patSyn pat sc = case pat of
95-
PInfixApp l pat1 name pat2 ->
96-
c PInfixApp
97-
<| sc -: l
98-
<| sc -: pat1
99-
<*> qname name sc
100-
<| sc -: pat2
101-
PApp l name pat ->
102-
c PApp
103-
<| sc -: l
104-
<*> qname name sc
105-
<| sc -: pat
106-
PRec l name pfs ->
107-
c PRec
108-
<| sc -: l
109-
<*> qname name sc
110-
<*> T.for pfs (`patSynField` sc)
111-
_ -> defaultRtraverse pat sc
112-
patSynField fs sc = case fs of
113-
PFieldPat l name pat ->
114-
c PFieldPat
115-
<| sc -: l
116-
<*> qname name sc
117-
<| sc -: pat
118-
PFieldPun l name ->
119-
c PFieldPun
120-
<| sc -: l
121-
<*> qname name sc
122-
PFieldWildcard {} -> defaultRtraverse fs sc
123-
qname name sc = fmap nameToQName (alg (qNameToName name) (binderV sc))
91+
12492

12593
instanceRuleClass :: InstRule l -> QName l
12694
instanceRuleClass (IParen _ instRule) = instanceRuleClass instRule

‎src/Language/Haskell/Names/ScopeUtils.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,8 @@ symbolParent (Constructor { typeName = n }) = Just n
2525
symbolParent (Method { className = n }) = Just n
2626
symbolParent (TypeFam { associate = as }) = as
2727
symbolParent (DataFam { associate = as }) = as
28+
symbolParent (PatternConstructor { patternTypeName = mn}) = mn
29+
symbolParent (PatternSelector { patternTypeName = mn}) = mn
2830
symbolParent _ = Nothing
2931

3032
computeSymbolTable

‎src/Language/Haskell/Names/Types.hs‎

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,11 +70,19 @@ data Symbol
7070
, symbolName :: Name ()
7171
}
7272
-- ^ type class
73-
| PatSyn
73+
| PatternConstructor
7474
{ symbolModule :: ModuleName ()
7575
, symbolName :: Name ()
76+
, patternTypeName :: Maybe (Name ())
7677
}
77-
-- ^ pattern synonym
78+
-- ^ pattern synonym constructor
79+
| PatternSelector
80+
{ symbolModule :: ModuleName ()
81+
, symbolName :: Name ()
82+
, patternTypeName :: Maybe (Name ())
83+
, patternConstructorName :: Name ()
84+
}
85+
-- ^ pattern synonym selector
7886
deriving (Eq, Ord, Show, Data, Typeable)
7987

8088
-- | A map from module name to list of symbols it exports.

‎tests/annotations/PatternSynonyms.hs‎

Lines changed: 38 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,42 @@
1-
{-# LANGUAGE PatternSynonyms #-}
1+
{-# LANGUAGE PatternSynonyms, NamedFieldPuns #-}
22

33
module PatternSynonyms where
44

5-
pattern SimplePat x y = [(Just [x], Right y)]
65

7-
pattern RecordPat { patLeft, patRight } = Just (patLeft, patRight)
6+
data Type = App String [Type]
7+
8+
pattern Arrow t1 t2 = App "->" [t1, t2]
9+
pattern Int = App "Int" []
10+
pattern Maybe t = App "Maybe" [t]
11+
12+
collectArgs :: Type -> [Type]
13+
collectArgs (Arrow t1 t2) = t1 : collectArgs t2
14+
collectArgs _ = []
15+
16+
isInt :: Type -> Bool
17+
isInt Int = True
18+
isInt _ = False
19+
20+
isIntEndo :: Type -> Bool
21+
isIntEndo (Arrow Int Int) = True
22+
isIntEndo _ = False
23+
24+
intEndo :: Type
25+
intEndo = Arrow Int Int
26+
27+
pattern Head x <- x:xs
28+
29+
pattern HeadC x <- x:xs where
30+
HeadC x = [x]
31+
32+
pattern Point :: Int -> Int -> (Int, Int)
33+
pattern Point{x, y} = (x, y)
34+
35+
zero = Point 0 0
36+
zero' = Point { x = 0, y = 0}
37+
isZero (Point 0 0) = True
38+
isZero' (Point { x = 0, y = 0 }) = True
39+
getX (Point {x}) = x
40+
setX = (0, 0) { x = 1 } == (1,0)
41+
getX' = x (0,0) == 0
42+

0 commit comments

Comments
 (0)