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         zipper_descendant         :: Ord k => term (Zipper k a) -> term [Zipper k a]
  33         zipper_descendant_or_self :: Ord k => term (Zipper k a) -> term [Zipper k a]
  34         zipper_child              :: Ord k => term (Zipper k a) -> term [Zipper k a]
  35         zipper_child_lookup       :: Ord k => Alternative f => term k -> term (Zipper k a) -> term (f (Zipper k a))
  36         zipper_child_lookups      :: Ord k => Alternative f => Monad f => term (TreeMap.Path k) -> term (Zipper k a) -> term (f (Zipper k a))
  37         zipper_child_first        :: Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
  38         zipper_child_last         :: Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
  39         zipper_ancestor           :: Ord k => term (Zipper k a) -> term [Zipper k a]
  40         zipper_ancestor_or_self   :: Ord k => term (Zipper k a) -> term [Zipper k a]
  41         zipper_preceding          :: Ord k => term (Zipper k a) -> term [Zipper k a]
  42         zipper_preceding_sibling  :: Ord k => term (Zipper k a) -> term [Zipper k a]
  43         zipper_following          :: Ord k => term (Zipper k a) -> term [Zipper k a]
  44         zipper_following_sibling  :: Ord k => term (Zipper k a) -> term [Zipper k a]
  45         zipper_parent             :: Ord k => term (Zipper k a) -> term [Zipper k a]
  46         default zipper_descendant         :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  47         default zipper_descendant_or_self :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  48         default zipper_child              :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  49         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))
  50         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))
  51         default zipper_child_first        :: Sym_Zipper (UnT term) => Trans term => Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
  52         default zipper_child_last         :: Sym_Zipper (UnT term) => Trans term => Ord k => Alternative f => term (Zipper k a) -> term (f (Zipper k a))
  53         default zipper_ancestor           :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  54         default zipper_ancestor_or_self   :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  55         default zipper_preceding          :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  56         default zipper_preceding_sibling  :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  57         default zipper_following          :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  58         default zipper_following_sibling  :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  59         default zipper_parent             :: Sym_Zipper (UnT term) => Trans term => Ord k => term (Zipper k a) -> term [Zipper k a]
  60         zipper_descendant         = trans1 zipper_descendant
  61         zipper_descendant_or_self = trans1 zipper_descendant_or_self
  62         zipper_child              = trans1 zipper_child
  63         zipper_child_lookup       = trans2 zipper_child_lookup
  64         zipper_child_lookups      = trans2 zipper_child_lookups
  65         zipper_child_first        = trans1 zipper_child_first
  66         zipper_child_last         = trans1 zipper_child_last
  67         zipper_ancestor           = trans1 zipper_ancestor
  68         zipper_ancestor_or_self   = trans1 zipper_ancestor_or_self
  69         zipper_preceding          = trans1 zipper_preceding
  70         zipper_preceding_sibling  = trans1 zipper_preceding_sibling
  71         zipper_following          = trans1 zipper_preceding
  72         zipper_following_sibling  = trans1 zipper_preceding
  73         zipper_parent             = trans1 zipper_preceding
  74
  75 instance Sym_Zipper Eval where
  76         zipper_descendant         = eval1 Zipper.zipper_descendant
  77         zipper_descendant_or_self = eval1 Zipper.zipper_descendant_or_self
  78         zipper_child              = eval1 Zipper.zipper_child
  79         zipper_child_lookup       = eval2 Zipper.zipper_child_lookup
  80         zipper_child_lookups      = eval2 Zipper.zipper_child_lookups
  81         zipper_child_first        = eval1 Zipper.zipper_child_first
  82         zipper_child_last         = eval1 Zipper.zipper_child_last
  83         zipper_ancestor           = eval1 Zipper.zipper_ancestor
  84         zipper_ancestor_or_self   = eval1 Zipper.zipper_ancestor_or_self
  85         zipper_preceding          = eval1 Zipper.zipper_preceding
  86         zipper_preceding_sibling  = eval1 Zipper.zipper_preceding_sibling
  87         zipper_following          = eval1 Zipper.zipper_following
  88         zipper_following_sibling  = eval1 Zipper.zipper_following_sibling
  89         zipper_parent             = eval1 Zipper.zipper_parent
  90 instance Sym_Zipper View where
  91         zipper_descendant         = view1 "TreeMap.Zipper.descendant"
  92         zipper_descendant_or_self = view1 "TreeMap.Zipper.descendant_or_self"
  93         zipper_child              = view1 "TreeMap.Zipper.child"
  94         zipper_child_lookup       = view2 "TreeMap.Zipper.child_lookup"
  95         zipper_child_lookups      = view2 "TreeMap.Zipper.child_lookups"
  96         zipper_child_first        = view1 "TreeMap.Zipper.child_first"
  97         zipper_child_last         = view1 "TreeMap.Zipper.child_last"
  98         zipper_ancestor           = view1 "TreeMap.Zipper.ancestor"
  99         zipper_ancestor_or_self   = view1 "TreeMap.Zipper.ancestor_or_self"
 100         zipper_preceding          = view1 "TreeMap.Zipper.preceding"
 101         zipper_preceding_sibling  = view1 "TreeMap.Zipper.preceding_sibling"
 102         zipper_following          = view1 "TreeMap.Zipper.following"
 103         zipper_following_sibling  = view1 "TreeMap.Zipper.following_sibling"
 104         zipper_parent             = view1 "TreeMap.Zipper.parent"
 105 instance (Sym_Zipper r1, Sym_Zipper r2) => Sym_Zipper (Dup r1 r2) where
 106         zipper_descendant         = dup1 @Sym_Zipper zipper_descendant
 107         zipper_descendant_or_self = dup1 @Sym_Zipper zipper_descendant_or_self
 108         zipper_child              = dup1 @Sym_Zipper zipper_child
 109         zipper_child_lookup       = dup2 @Sym_Zipper zipper_child_lookup
 110         zipper_child_lookups      = dup2 @Sym_Zipper zipper_child_lookups
 111         zipper_child_first        = dup1 @Sym_Zipper zipper_child_first
 112         zipper_child_last         = dup1 @Sym_Zipper zipper_child_last
 113         zipper_ancestor           = dup1 @Sym_Zipper zipper_ancestor
 114         zipper_ancestor_or_self   = dup1 @Sym_Zipper zipper_ancestor_or_self
 115         zipper_preceding          = dup1 @Sym_Zipper zipper_preceding
 116         zipper_preceding_sibling  = dup1 @Sym_Zipper zipper_preceding_sibling
 117         zipper_following          = dup1 @Sym_Zipper zipper_following
 118         zipper_following_sibling  = dup1 @Sym_Zipper zipper_following_sibling
 119         zipper_parent             = dup1 @Sym_Zipper zipper_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 _ (TyApp _ (TyConst _ _ _q) (TyApp _ 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 _ (TyApp _ tq@(TyConst _ _ q) (TyApp _ (TyApp _ 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          ]