{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.Symantic.Typing.Module where

import Data.Functor (Functor(..))
import Data.Maybe (fromMaybe)
import Data.String (IsString(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Typeable
import Data.Map.Strict (Map)
import qualified Data.Char as C
import qualified Data.List as L
import qualified Data.Kind as K
import qualified Data.Text as T
import qualified Data.Map.Strict as Map

import Language.Symantic.Grammar.Fixity

-- * Type 'NsT'
data NsT
 =   NsTerm
 |   NsType

-- * Type 'Name'
type Name = Text

-- * Type 'NameTy'
-- | 'Name' of a 'Type'.
newtype NameTy = NameTy Text
 deriving (Eq, Ord, Show)
instance IsString NameTy where
	fromString = NameTy . fromString

-- ** Type 'NameConst'
-- | 'Name' of a 'Const'.
type NameConst = NameTy

-- ** Type 'NameFam'
-- | 'Name' of a 'Fam'.
type NameFam = NameTy

-- ** Class 'NameOf'
class NameOf a where
	nameOf :: a -> Name

-- ** Class 'NameTyOf'
-- | Return the 'NameTy' of something.
class NameTyOf (c::kc) where
	nameTyOf :: proxy c -> Mod NameTy
	default nameTyOf :: Typeable c => proxy c -> Mod NameTy
	nameTyOf c = path (tyConModule repr) `Mod` fromString (tyConName repr)
		where
		repr = typeRepTyCon (typeRep c)
		path = fmap fromString . L.lines . fmap (\case '.' -> '\n'; x -> x)
	
	isNameTyOp :: proxy c -> Bool
	default isNameTyOp :: Typeable c => proxy c -> Bool
	isNameTyOp c = let _m `Mod` NameTy n = nameTyOf c in isOp n
		where
		isOp = T.all $ \case
			 '_'  -> False
			 '\'' -> False
			 x -> case C.generalCategory x of
				 C.NonSpacingMark       -> True
				 C.SpacingCombiningMark -> True
				 C.EnclosingMark        -> True
				 C.ConnectorPunctuation -> True
				 C.DashPunctuation      -> True
				 C.OpenPunctuation      -> True
				 C.ClosePunctuation     -> True
				 C.InitialQuote         -> True
				 C.FinalQuote           -> True
				 C.OtherPunctuation     -> True
				 C.MathSymbol           -> True
				 C.CurrencySymbol       -> True
				 C.ModifierSymbol       -> True
				 C.OtherSymbol          -> True
				 
				 C.UppercaseLetter      -> False
				 C.LowercaseLetter      -> False
				 C.TitlecaseLetter      -> False
				 C.ModifierLetter       -> False
				 C.OtherLetter          -> False
				 C.DecimalNumber        -> False
				 C.LetterNumber         -> False
				 C.OtherNumber          -> False
				 C.Space                -> False
				 C.LineSeparator        -> False
				 C.ParagraphSeparator   -> False
				 C.Control              -> False
				 C.Format               -> False
				 C.Surrogate            -> False
				 C.PrivateUse           -> False
				 C.NotAssigned          -> False

-- * Type 'Mod'
-- | 'PathMod' of something.
data Mod a = Mod PathMod a
 deriving (Eq, Functor, Ord, Show)

-- ** Type 'PathMod'
-- | Path to a 'Module'.
type PathMod = [NameMod]

-- ** Type 'NameMod'
-- | 'Name' of 'Module'.
newtype NameMod = NameMod Name
 deriving (Eq, Ord, Show)
instance IsString NameMod where
	fromString = NameMod . fromString

-- * Type 'Imports'
-- | Map 'PathMod's of 'Name's.
newtype Imports name = Imports (Map PathMod (MapFixity (Map name PathMod)))
 deriving (Eq, Show)

instance Ord name => Semigroup (Imports name) where
	Imports x <> Imports y = Imports $ Map.unionWith (<>) x y
instance Ord name => Monoid (Imports name) where
	mempty  = Imports mempty
	mappend = (<>)

lookupImports :: Ord name => Fixy p i q a -> Mod name -> Imports name -> Maybe PathMod
lookupImports f (m `Mod` n) (Imports is) =
	Map.lookup m is >>=
	Map.lookup n . getByFixity f

revlookupImports :: Ord name => Fixy p i q a -> Mod name -> Imports name -> Maybe PathMod
revlookupImports f (m `Mod` n) (Imports is) =
	(fst . fst <$>) $ Map.minViewWithKey $
	Map.filter (\i ->
		case Map.lookup n $ getByFixity f i of
		 Just m' | m' == m -> True
		 _ -> False
	 ) is

-- ** Class 'ImportTypes'
class ImportTypes ts where
	importTypes :: PathMod -> Imports NameTy

instance ImportTypes '[] where
	importTypes _p = mempty
instance (NameTyOf t, FixityOf t, ImportTypes ts) => ImportTypes (Proxy t ': ts) where
	importTypes p = Imports (Map.singleton p byFixy) <> importTypes @ts p
		where
		t = Proxy @t
		f = Fixity2 infixN5 `fromMaybe` fixityOf t
		m `Mod` n = nameTyOf t
		byFixy :: MapFixity (Map NameTy PathMod)
		byFixy = case f of
			Fixity1 Prefix{}  -> ByFixity{byPrefix  = Map.singleton n m, byInfix =mempty, byPostfix=mempty}
			Fixity2{}         -> ByFixity{byInfix   = Map.singleton n m, byPrefix=mempty, byPostfix=mempty}
			Fixity1 Postfix{} -> ByFixity{byPostfix = Map.singleton n m, byPrefix=mempty, byInfix  =mempty}

-- * Type 'Fixy'
data Fixy p i q a where
 FixyPrefix  :: Fixy p i q p
 FixyInfix   :: Fixy p i q i
 FixyPostfix :: Fixy p i q q
deriving instance Eq   (Fixy p i q a)
deriving instance Show (Fixy p i q a)

fixyOfFixity :: Fixity -> Fixy a a a a
fixyOfFixity (Fixity1 Prefix{})  = FixyPrefix
fixyOfFixity (Fixity2 Infix{})   = FixyInfix
fixyOfFixity (Fixity1 Postfix{}) = FixyPostfix

-- ** Class 'FixityOf'
-- | Return the 'Fixity' of something.
class FixityOf (c::kc) where
	fixityOf :: proxy c -> Maybe Fixity
	fixityOf _c = Nothing
instance FixityOf (c::K.Type)
instance FixityOf (c::K.Constraint)

-- ** Type 'FixyA'
-- | Like 'Fixy', but when all choices have the same type.
newtype FixyA = FixyA (forall (a:: *). Fixy a a a a)
deriving instance Eq   FixyA
deriving instance Show FixyA

-- ** Type 'WithFixity'
data WithFixity a
 =   WithFixity a Fixity
 deriving (Eq, Functor, Show)
instance IsString a => IsString (WithFixity a) where
	fromString a = WithFixity (fromString a) (Fixity2 infixN5)

withInfix :: a -> Infix -> WithFixity a
withInfix a inf = a `WithFixity` Fixity2 inf
withInfixR :: a -> Precedence -> WithFixity a
withInfixR a p = a `WithFixity` Fixity2 (infixR p)
withInfixL :: a -> Precedence -> WithFixity a
withInfixL a p = a `WithFixity` Fixity2 (infixL p)
withInfixN :: a -> Precedence -> WithFixity a
withInfixN a p = a `WithFixity` Fixity2 (infixN p)
withInfixB :: a -> (Side, Precedence) -> WithFixity a
withInfixB a (lr, p) = a `WithFixity` Fixity2 (infixB lr p)
withPrefix :: a -> Precedence -> WithFixity a
withPrefix a p = a `WithFixity` Fixity1 (Prefix p)
withPostfix :: a -> Precedence -> WithFixity a
withPostfix a p = a `WithFixity` Fixity1 (Postfix p)

-- ** Type 'ByFixity'
-- | Fixity namespace.
data ByFixity p i q
 =   ByFixity
 {   byPrefix  :: p
 ,   byInfix   :: i
 ,   byPostfix :: q
 } deriving (Eq, Show)
instance (Semigroup p, Semigroup i, Semigroup q) => Semigroup (ByFixity p i q) where
	ByFixity px ix qx <> ByFixity py iy qy =
		ByFixity (px <> py) (ix <> iy) (qx <> qy)
instance (Monoid p, Monoid i, Monoid q) => Monoid (ByFixity p i q) where
	mempty = ByFixity mempty mempty mempty
	ByFixity px ix qx `mappend` ByFixity py iy qy =
		ByFixity (px `mappend` py) (ix `mappend` iy) (qx `mappend` qy)

getByFixity :: Fixy p i q a -> MapFixity b -> b
getByFixity FixyPrefix  = byPrefix
getByFixity FixyInfix   = byInfix
getByFixity FixyPostfix = byPostfix

selectByFixity :: Fixy p i q a -> ByFixity p i q -> a
selectByFixity FixyPrefix  = byPrefix
selectByFixity FixyInfix   = byInfix
selectByFixity FixyPostfix = byPostfix

-- *** Type 'MapFixity'
-- | Like 'ByFixity', but with the same type parameter.
type MapFixity a = ByFixity a a a

mapMapFixity :: (a -> b) -> MapFixity a -> MapFixity b
mapMapFixity f (ByFixity p i q) = ByFixity (f p) (f i) (f q)