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