Improve help rendition.

[haskell/symantic.git] / symantic / Language / Symantic / Parsing / Token.hs

diff --git a/symantic/Language/Symantic/Parsing/Token.hs b/symantic/Language/Symantic/Parsing/Token.hs
index 9cbaddb6485237fb210ef40cb1d06ae4155e8d67..2c8b3ce17ad77b2bd979d4b44c4d1d709d941706 100644 (file)
--- a/symantic/Language/Symantic/Parsing/Token.hs
+++ b/symantic/Language/Symantic/Parsing/Token.hs
@@ -1,18 +1,9 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE UndecidableInstances #-}
+-- | Legacy code no longer used, for reminder only.
 module Language.Symantic.Parsing.Token where
 
-import Data.Maybe (isJust)
-import Data.Proxy (Proxy(..))
 import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Data.Type.Equality
 
 import Language.Symantic.Grammar (Gram_Meta(..))
-import Language.Symantic.Helper.Data.Type.List
-import Language.Symantic.Helper.Data.Type.Peano
 
 -- * Type 'Token'
 type Token ss = TokenR ss ss
@@ -32,16 +23,16 @@ instance
  ( Eq (TokenT ss (Proxy s))
  , TestEquality (TokenR ss (r ': rs))
  ) => TestEquality (TokenR ss (Proxy s ': r ': rs)) where
-       testEquality (TokenZ x) (TokenZ y) | x == y = Just Refl
-       testEquality (TokenS x) (TokenS y) | Just Refl <- testEquality x y = Just Refl
-       testEquality _ _ = Nothing
+       ctxtEquality (TokenZ x) (TokenZ y) | x == y = Just Refl
+       ctxtEquality (TokenS x) (TokenS y) | Just Refl <- ctxtEquality x y = Just Refl
+       ctxtEquality _ _ = Nothing
 instance
  Eq (TokenT ss (Proxy s)) =>
  TestEquality (TokenR ss (Proxy s ': '[])) where
-       testEquality (TokenZ x) (TokenZ y) | x == y = Just Refl
-       testEquality _ _ = Nothing
+       ctxtEquality (TokenZ x) (TokenZ y) | x == y = Just Refl
+       ctxtEquality _ _ = Nothing
 instance TestEquality (TokenR ss rs) => Eq (TokenR ss rs s) where
-       x == y = isJust $ testEquality x y
+       x == y = isJust $ ctxtEquality x y
 
 -- ** Type 'Show_Token'
 type Show_Token ss = Show_TokenR ss ss
@@ -125,13 +116,13 @@ data EToken src (ss::[*])
  = forall s. EToken src (Token ss (Proxy s))
 
 instance Eq_Token ss => Eq (EToken src ss) where
-       EToken _sx x == EToken _sy y = isJust $ testEquality x y
+       EToken _sx x == EToken _sy y = isJust $ ctxtEquality x y
 instance Show_Token ss => Show (EToken src ss) where
        show (EToken _src x) = show x
+type instance SourceOf (EToken src ss) = src
 instance Source src => Sourced (EToken src ss) where
-       type Source_of (EToken src ss)  = src
-       source_of (EToken src _tok)     = src
-       source_is (EToken _src tok) src = EToken src tok
+       sourceOf (EToken src _tok)     = src
+       setSource (EToken _src tok) src = EToken src tok
 
 inj_EToken
  :: forall src ss s.
@@ -148,80 +139,3 @@ proj_EToken (EToken src (tok::TokenR ss ss (Proxy u))) =
        case proj_Token tok of
         Just (Refl :: Proxy s :~: Proxy u, to) -> Just (src, to)
         Nothing -> Nothing
-
--- * Class 'Source'
-class Source src where
-       sourceLess :: src
-instance Source () where
-       sourceLess = ()
-
--- * Class 'Inj_Source'
-class Source src => Inj_Source a src where
-       inj_Source :: a -> src
-instance Inj_Source a () where
-       inj_Source _ = ()
-
--- ** Type 'Sourced'
-class Source (Source_of a) => Sourced a where
-       type Source_of a
-       source_of :: a -> Source_of a
-       source_is :: a -> Source_of a -> a
-infixl 5 `source_is`
-
-source :: (Inj_Source src (Source_of a), Sourced a) => a -> src -> a
-source a src = a `source_is` inj_Source src
-
--- ** Type 'Text_of_Source'
-type family Text_of_Source (src :: *) :: *
-type instance Text_of_Source () = ()
-
-sourceG :: forall meta src g a.
- ( Gram_Meta meta g
- , meta ~ Text_of_Source src
- , Inj_Source meta src
- , Functor g
- ) => g (src -> a) -> g a
-sourceG g = metaG $ (\f (txt::Text_of_Source src) -> f (inj_Source txt :: src)) <$> g
-
--- * Type 'At'
--- | Attach a source.
-data At src a
- =   At src a
- deriving (Eq, Show)
-
-instance Functor (At src) where
-       fmap f (At src a) = At src (f a)
-unAt :: At src a -> a
-unAt (At _ a) = a
-
--- * Type 'BinTree'
--- | Binary Tree.
-data BinTree a
- =   BinTree0 a
- |   BinTree1 (BinTree a) (BinTree a)
- deriving (Eq, Show)
-
-instance Semigroup (BinTree a) where
-       (<>) = BinTree1
-instance Functor BinTree where
-       fmap f (BinTree0 a)   = BinTree0 (f a)
-       fmap f (BinTree1 x y) = BinTree1 (fmap f x) (fmap f y)
-instance Applicative BinTree where
-       pure = BinTree0
-       BinTree0 f     <*> BinTree0 a   = BinTree0 (f a)
-       BinTree0 f     <*> BinTree1 x y = BinTree1 (f  <$> x) (f  <$> y)
-       BinTree1 fx fy <*> a            = BinTree1 (fx <*> a) (fy <*> a)
-instance Monad BinTree where
-       return = BinTree0
-       BinTree0 a   >>= f = f a
-       BinTree1 x y >>= f = BinTree1 (x >>= f) (y >>= f)
-instance Foldable BinTree where
-       foldMap f (BinTree0 a)   = f a
-       foldMap f (BinTree1 x y) = foldMap f x `mappend` foldMap f y
-       foldr f acc (BinTree0 a)   = f a acc
-       foldr f acc (BinTree1 x y) = foldr f (foldr f acc y) x
-       foldl f acc (BinTree0 a)   = f acc a
-       foldl f acc (BinTree1 x y) = foldl f (foldl f acc x) y
-instance Traversable BinTree where
-       traverse f (BinTree0 a)   = BinTree0 <$> f a
-       traverse f (BinTree1 x y) = BinTree1 <$> traverse f x <*> traverse f y