never executed always true always false
1 {-# LANGUAGE Rank2Types #-}
2 {-# LANGUAGE TypeFamilies #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5 {-# LANGUAGE UndecidableInstances #-}
6 {-# LANGUAGE FunctionalDependencies #-}
7 {-# LANGUAGE DataKinds #-}
8 {-# LANGUAGE PolyKinds #-}
9
10 module AST.Structure
11 ( FixAST, ASTNS, ASTNS1
12 , foldReferences
13 , bottomUpReferences
14 , mapNs
15 ) where
16
17
18 import Data.Coapplicative
19 import Data.Foldable (fold)
20 import Data.Functor.Const
21 import AST.V0_16
22 import qualified Data.Indexed as I
23
24
25 -- FixAST :: (* -> *) -> * -> * -> * -> NodeKind -> *
26 type FixAST annf typeRef ctorRef varRef =
27 I.Fix annf (AST typeRef ctorRef varRef)
28
29 -- ASTNS :: (* -> *) -> * -> NodeKind -> *
30 type ASTNS annf ns =
31 FixAST annf (ns, UppercaseIdentifier) (ns, UppercaseIdentifier) (Ref ns)
32
33 -- This is the same as ASTNS, but with the first level unFix'ed
34 -- ASTNS1 :: (* -> *) -> * -> NodeKind -> *
35 type ASTNS1 annf ns =
36 AST
37 (ns, UppercaseIdentifier)
38 (ns, UppercaseIdentifier)
39 (Ref ns)
40 (ASTNS annf ns)
41
42
43 bottomUpReferences ::
44 (Functor annf) =>
45 (typeRef1 -> typeRef2)
46 -> (ctorRef1 -> ctorRef2)
47 -> (varRef1 -> varRef2)
48 -> (forall kind.
49 FixAST annf typeRef1 ctorRef1 varRef1 kind
50 -> FixAST annf typeRef2 ctorRef2 varRef2 kind
51 )
52 bottomUpReferences ftr fcr fvr =
53 I.cata (I.Fix . fmap (mapAll ftr fcr fvr id))
54
55
56 foldReferences ::
57 forall a annf typeRef ctorRef varRef kind.
58 (Monoid a, Coapplicative annf) =>
59 (typeRef -> a) -> (ctorRef -> a) -> (varRef -> a)
60 -> FixAST annf typeRef ctorRef varRef kind -> a
61 foldReferences ftype fctor fvar =
62 getConst . I.cata (foldNode . extract)
63 where
64 -- This is kinda confusing, but we use the Const type constructor to merge all the different NodeKinds into a single type `a`
65 -- See http://www.timphilipwilliams.com/posts/2013-01-16-fixing-gadts.html for relevant details.
66 foldNode :: forall kind'. AST typeRef ctorRef varRef (Const a) kind' -> Const a kind'
67 foldNode = \case
68 TopLevel tls -> Const $ foldMap (foldMap getConst) tls
69
70 -- Declarations
71 Definition name args _ e -> Const (getConst name <> foldMap (getConst . extract) args <> getConst e)
72 TypeAnnotation _ t -> Const (getConst $ extract t)
73 CommonDeclaration d -> Const $ getConst d
74 Datatype _ ctors -> Const (foldMap (getConst . fold) ctors)
75 TypeAlias _ _ t -> Const (getConst $ extract t)
76 PortAnnotation _ _ t -> Const (getConst t)
77 PortDefinition_until_0_16 _ _ e -> Const (getConst e)
78 Fixity_until_0_18 _ _ _ _ name -> Const (fvar name)
79 Fixity _ _ _ _ -> mempty
80
81 -- Expressions
82 Unit _ -> mempty
83 Literal _ -> mempty
84 VarExpr var -> Const $ fvar var
85 App first rest _ -> first <> mconcat (fmap extract rest)
86 Unary _ e -> e
87 Binops first ops _ -> Const (getConst first <> foldMap foldBinopsClause ops)
88 Parens e -> extract e
89 ExplicitList terms _ _ -> fold terms
90 Range left right _ -> extract left <> extract right
91 Tuple terms _ -> mconcat $ fmap extract terms
92 TupleFunction _ -> mempty
93 Record _ fields _ _ -> foldMap (extract . _value) fields
94 Access e _ -> e
95 AccessFunction _ -> mempty
96 Lambda args _ e _ -> Const (foldMap (getConst . extract) args <> getConst e)
97 If cond elsifs els -> Const (foldIfClause cond <> foldMap (foldIfClause . extract) elsifs <> getConst (extract els))
98 Let defs _ e -> Const (foldMap getConst defs <> getConst e)
99 LetCommonDeclaration d -> Const $ getConst d
100 LetComment _ -> mempty
101 Case (cond, _) branches -> Const (getConst (extract cond) <> foldMap getConst branches)
102 CaseBranch _ _ _ p e -> Const (getConst p <> getConst e)
103 GLShader _ -> mempty
104
105 -- Patterns
106 Anything -> mempty
107 UnitPattern _ -> mempty
108 LiteralPattern _ -> mempty
109 VarPattern _ -> mempty
110 OpPattern _ -> mempty
111 DataPattern ctor args -> Const (fctor ctor <> foldMap (getConst . extract) args)
112 PatternParens p -> extract p
113 TuplePattern terms -> foldMap extract terms
114 EmptyListPattern _ -> mempty
115 ListPattern terms -> foldMap extract terms
116 ConsPattern first rest -> extract first <> fold rest
117 EmptyRecordPattern _ -> mempty
118 RecordPattern _ -> mempty
119 Alias p _ -> extract p
120
121 -- Types
122 UnitType _ -> mempty
123 TypeVariable _ -> mempty
124 TypeConstruction name args _ -> Const (foldTypeConstructor name <> foldMap (getConst . extract) args)
125 TypeParens typ -> extract typ
126 TupleType terms _ -> foldMap extract terms
127 RecordType _ fields _ _ -> foldMap (extract . _value) fields
128 FunctionType first rest _ -> extract first <> fold rest
129
130 foldTypeConstructor :: TypeConstructor typeRef -> a
131 foldTypeConstructor = \case
132 NamedConstructor name -> ftype name
133 TupleConstructor _ -> mempty
134
135 foldBinopsClause :: BinopsClause varRef (Const a 'ExpressionNK) -> a
136 foldBinopsClause = \case
137 BinopsClause _ op _ e -> fvar op <> getConst e
138
139 foldIfClause :: IfClause (Const a 'ExpressionNK) -> a
140 foldIfClause = \case
141 IfClause cond els -> getConst (extract cond) <> getConst (extract els)
142
143
144 mapNs ::
145 Functor annf =>
146 (ns1 -> ns2)
147 -> (forall kind.
148 ASTNS annf ns1 kind
149 -> ASTNS annf ns2 kind
150 )
151 mapNs f =
152 let
153 mapTypeRef (ns, u) = (f ns, u)
154 mapCtorRef (ns, u) = (f ns, u)
155 mapVarRef (VarRef ns l) = VarRef (f ns) l
156 mapVarRef (TagRef ns u) = TagRef (f ns) u
157 mapVarRef (OpRef op) = OpRef op
158 in
159 bottomUpReferences mapTypeRef mapCtorRef mapVarRef