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          ]