1
1
mirror of https://github.com/github/semantic.git synced 2024-12-26 00:12:29 +03:00

🔥 AST.Element for now.

This commit is contained in:
Rob Rix 2019-09-24 14:11:38 -04:00
parent 1aa4e9a87f
commit ad43b0c1a2
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 0 additions and 66 deletions

View File

@ -20,7 +20,6 @@ tested-with: GHC == 8.6.5
library
exposed-modules:
AST.Element
Tags.Tag
Tags.Taggable.Precise
-- other-modules:

View File

@ -1,65 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes, DataKinds, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
module AST.Element
( Element(..)
) where
import GHC.Generics
import GHC.TypeLits (ErrorMessage(..), TypeError)
class Element sub sup where
prj :: sup a -> Maybe (sub a)
instance (Element' elem sub sup, elem ~ Elem sub sup) => Element sub sup where
prj = prj' @elem
type family Elem sub sup where
Elem t t = 'True
Elem t (l :+: r) = Elem t l || Elem t r
Elem _ _ = 'False
type family a || b where
'True || _ = 'True
_ || 'True = 'True
_ || _ = 'False
class Element' (elem :: Bool) sub sup where
prj' :: sup a -> Maybe (sub a)
instance {-# OVERLAPPABLE #-}
Element' 'True t t where
prj' = Just
instance {-# OVERLAPPABLE #-}
Element' 'True t (l1 :+: l2 :+: r)
=> Element' 'True t ((l1 :+: l2) :+: r) where
prj' = prj' @'True . reassoc where
reassoc (L1 (L1 l)) = L1 l
reassoc (L1 (R1 l)) = R1 (L1 l)
reassoc (R1 r) = R1 (R1 r)
instance {-# OVERLAPPABLE #-}
Element' 'True t (t :+: r) where
prj' (L1 l) = Just l
prj' _ = Nothing
instance {-# OVERLAPPABLE #-}
Element' 'True t r
=> Element' 'True t (l :+: r) where
prj' (R1 r) = prj' @'True r
prj' _ = Nothing
type family ShowSum t where
ShowSum (l :+: r) = ShowSum' ('Text "{ ") (l :+: r) ':$$: 'Text "}"
ShowSum t = 'Text "{ " ':<>: 'ShowType t ':<>: 'Text " }"
type family ShowSum' p t where
ShowSum' p (l :+: r) = ShowSum' p l ':$$: ShowSum' ('Text ", ") r
ShowSum' p t = p ':<>: 'ShowType t
instance TypeError
( 'ShowType t ':<>: 'Text " is not in"
':$$: ShowSum u)
=> Element' 'False t u where
prj' _ = Nothing