]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Sym/Zipper.hs
Remove old Yesod scaffolding.
[comptalang.git] / lcc / Hcompta / LCC / Sym / Zipper.hs
1 {-# LANGUAGE UndecidableInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 -- | Symantic for 'Zipper'.
4 module Hcompta.LCC.Sym.Zipper where
5
6 import Control.Applicative (Alternative(..))
7 import Control.Monad (Monad)
8 import Data.Eq (Eq)
9 import Data.Maybe (Maybe(..))
10 import Data.Ord (Ord)
11 import Data.Proxy
12 import Data.TreeMap.Strict.Zipper (Zipper)
13 import Data.Type.Equality ((:~:)(Refl))
14 import Text.Show (Show(..))
15 import qualified Data.TreeMap.Strict as TreeMap
16 import qualified Data.TreeMap.Strict.Zipper as Zipper
17 {-
18 import Data.Foldable (Foldable(..))
19 import Data.Function (($))
20 import Data.Functor (Functor(..))
21 import Data.Monoid (Monoid(..))
22 import Data.NonNull (NonNull)
23 import Data.Traversable (Traversable(..))
24 -}
25
26 import Language.Symantic.Grammar
27 import Language.Symantic
28 import Language.Symantic.Lib ()
29
30 -- * Class 'Sym_Zipper'
31 type instance Sym (Proxy Zipper) = Sym_Zipper
32 class Sym_Zipper term where
33 zipper_descendant :: Ord k => term (Zipper k a) -> term [Zipper k a]
34 zipper_descendant_or_self :: Ord k => term (Zipper k a) -> term [Zipper k a]
35 zipper_child :: Ord k => term (Zipper k a) -> term [Zipper k a]
36 zipper_child_lookup :: Ord k => Alternative f => term k -> term (Zipper k a) -> term (f (Zipper k a))
37 zipper_child_lookups :: Ord k => Alternative f => Monad f => term (TreeMap.Path k) -> term (Zipper k a) -> term (f (Zipper k a))
38 zipper_child_first :: Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
39 zipper_child_last :: Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
40 zipper_ancestor :: Ord k => term (Zipper k a) -> term [Zipper k a]
41 zipper_ancestor_or_self :: Ord k => term (Zipper k a) -> term [Zipper k a]
42 zipper_preceding :: Ord k => term (Zipper k a) -> term [Zipper k a]
43 zipper_preceding_sibling :: Ord k => term (Zipper k a) -> term [Zipper k a]
44 zipper_following :: Ord k => term (Zipper k a) -> term [Zipper k a]
45 zipper_following_sibling :: Ord k => term (Zipper k a) -> term [Zipper k a]
46 zipper_parent :: Ord k => term (Zipper k a) -> term [Zipper k a]
47 default zipper_descendant :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
48 default zipper_descendant_or_self :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
49 default zipper_child :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
50 default zipper_child_lookup :: Sym_Zipper (UnT term) => Trans term => Ord k => Alternative f => term k -> term (Zipper k a) -> term (f (Zipper k a))
51 default zipper_child_lookups :: Sym_Zipper (UnT term) => Trans term => Ord k => Alternative f => Monad f => term (TreeMap.Path k) -> term (Zipper k a) -> term (f (Zipper k a))
52 default zipper_child_first :: Sym_Zipper (UnT term) => Trans term => Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
53 default zipper_child_last :: Sym_Zipper (UnT term) => Trans term => Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
54 default zipper_ancestor :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
55 default zipper_ancestor_or_self :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
56 default zipper_preceding :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
57 default zipper_preceding_sibling :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
58 default zipper_following :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
59 default zipper_following_sibling :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
60 default zipper_parent :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
61 zipper_descendant = trans1 zipper_descendant
62 zipper_descendant_or_self = trans1 zipper_descendant_or_self
63 zipper_child = trans1 zipper_child
64 zipper_child_lookup = trans2 zipper_child_lookup
65 zipper_child_lookups = trans2 zipper_child_lookups
66 zipper_child_first = trans1 zipper_child_first
67 zipper_child_last = trans1 zipper_child_last
68 zipper_ancestor = trans1 zipper_ancestor
69 zipper_ancestor_or_self = trans1 zipper_ancestor_or_self
70 zipper_preceding = trans1 zipper_preceding
71 zipper_preceding_sibling = trans1 zipper_preceding_sibling
72 zipper_following = trans1 zipper_preceding
73 zipper_following_sibling = trans1 zipper_preceding
74 zipper_parent = trans1 zipper_preceding
75
76 instance Sym_Zipper Eval where
77 zipper_descendant = eval1 Zipper.zipper_descendant
78 zipper_descendant_or_self = eval1 Zipper.zipper_descendant_or_self
79 zipper_child = eval1 Zipper.zipper_child
80 zipper_child_lookup = eval2 Zipper.zipper_child_lookup
81 zipper_child_lookups = eval2 Zipper.zipper_child_lookups
82 zipper_child_first = eval1 Zipper.zipper_child_first
83 zipper_child_last = eval1 Zipper.zipper_child_last
84 zipper_ancestor = eval1 Zipper.zipper_ancestor
85 zipper_ancestor_or_self = eval1 Zipper.zipper_ancestor_or_self
86 zipper_preceding = eval1 Zipper.zipper_preceding
87 zipper_preceding_sibling = eval1 Zipper.zipper_preceding_sibling
88 zipper_following = eval1 Zipper.zipper_following
89 zipper_following_sibling = eval1 Zipper.zipper_following_sibling
90 zipper_parent = eval1 Zipper.zipper_parent
91 instance Sym_Zipper View where
92 zipper_descendant = view1 "TreeMap.Zipper.descendant"
93 zipper_descendant_or_self = view1 "TreeMap.Zipper.descendant_or_self"
94 zipper_child = view1 "TreeMap.Zipper.child"
95 zipper_child_lookup = view2 "TreeMap.Zipper.child_lookup"
96 zipper_child_lookups = view2 "TreeMap.Zipper.child_lookups"
97 zipper_child_first = view1 "TreeMap.Zipper.child_first"
98 zipper_child_last = view1 "TreeMap.Zipper.child_last"
99 zipper_ancestor = view1 "TreeMap.Zipper.ancestor"
100 zipper_ancestor_or_self = view1 "TreeMap.Zipper.ancestor_or_self"
101 zipper_preceding = view1 "TreeMap.Zipper.preceding"
102 zipper_preceding_sibling = view1 "TreeMap.Zipper.preceding_sibling"
103 zipper_following = view1 "TreeMap.Zipper.following"
104 zipper_following_sibling = view1 "TreeMap.Zipper.following_sibling"
105 zipper_parent = view1 "TreeMap.Zipper.parent"
106 instance (Sym_Zipper r1, Sym_Zipper r2) => Sym_Zipper (Dup r1 r2) where
107 zipper_descendant = dup1 @Sym_Zipper zipper_descendant
108 zipper_descendant_or_self = dup1 @Sym_Zipper zipper_descendant_or_self
109 zipper_child = dup1 @Sym_Zipper zipper_child
110 zipper_child_lookup = dup2 @Sym_Zipper zipper_child_lookup
111 zipper_child_lookups = dup2 @Sym_Zipper zipper_child_lookups
112 zipper_child_first = dup1 @Sym_Zipper zipper_child_first
113 zipper_child_last = dup1 @Sym_Zipper zipper_child_last
114 zipper_ancestor = dup1 @Sym_Zipper zipper_ancestor
115 zipper_ancestor_or_self = dup1 @Sym_Zipper zipper_ancestor_or_self
116 zipper_preceding = dup1 @Sym_Zipper zipper_preceding
117 zipper_preceding_sibling = dup1 @Sym_Zipper zipper_preceding_sibling
118 zipper_following = dup1 @Sym_Zipper zipper_following
119 zipper_following_sibling = dup1 @Sym_Zipper zipper_following_sibling
120 zipper_parent = dup1 @Sym_Zipper zipper_parent
121 instance (Sym_Zipper term, Sym_Lambda term) => Sym_Zipper (BetaT term)
122
123 instance FixityOf Zipper
124 instance ClassInstancesFor Zipper where
125 proveConstraintFor _ (TyApp _ (TyConst _ _ _q) (TyApp _ c _k))
126 | Just HRefl <- proj_ConstKiTy @(K Zipper) @Zipper c
127 = case () of
128 {-_ | Just Refl <- proj_Const @Functor q -> Just Dict
129 | Just Refl <- proj_Const @Foldable q -> Just Dict
130 | Just Refl <- proj_Const @Traversable q -> Just Dict
131 -}
132 _ -> Nothing
133 proveConstraintFor _ (TyApp _ tq@(TyConst _ _ q) (TyApp _ (TyApp _ c k) a))
134 | Just HRefl <- proj_ConstKiTy @(K Zipper) @Zipper c
135 = case () of
136 _ | Just Refl <- proj_Const @Eq q
137 , Just Dict <- proveConstraint (tq `tyApp` k)
138 , Just Dict <- proveConstraint (tq `tyApp` a) -> Just Dict
139 {-| Just Refl <- proj_Const @Ord q
140 , Just Dict <- proveConstraint (tq `tyApp` k)
141 , Just Dict <- proveConstraint (tq `tyApp` a) -> Just Dict
142 | Just Refl <- proj_Const @Monoid q
143 , Just Dict <- proveConstraint (tyOrd k) -> Just Dict
144 -}
145 | Just Refl <- proj_Const @Show q
146 , Just Dict <- proveConstraint (tq `tyApp` k)
147 , Just Dict <- proveConstraint (tq `tyApp` a) -> Just Dict
148 _ -> Nothing
149 proveConstraintFor _c _q = Nothing
150 instance TypeInstancesFor Zipper
151
152 instance -- Gram_Term_AtomsFor
153 ( Gram_Alt g
154 , Gram_Rule g
155 , Gram_Comment g
156 , Gram_Source src g
157 , Inj_Sym ss Zipper
158 ) => Gram_Term_AtomsFor src ss g Zipper where
159 {-
160 gs_term_atomsFor _t =
161 [ rule "term_account" $
162 lexeme $ withMeta $
163 (\a meta -> ProTokTe $ inj_EToken meta $ Token_Term_Zipper a)
164 <$> g_account
165 ]
166 where
167 g_account :: CF g Zipper
168 g_account =
169 Zipper . NonNull.impureNonNull
170 <$> some (id <$ char '/' <*> g_account_section)
171 g_account_section :: CF g Zipper_Section
172 g_account_section =
173 Name . Text.pack
174 <$> some (choice $ unicat <$> [Unicat_Letter])
175 -}
176 instance (Source src, Inj_Sym ss Zipper) => ModuleFor src ss Zipper where
177 moduleFor = ["TreeMap", "Zipper"] `moduleWhere`
178 [
179 ]