{-# LANGUAGE CPP, PatternSynonyms, ViewPatterns, OverloadedStrings #-}

module HsDev.Symbols.Name (
	Name, qualName, unqualName, nameModule, nameIdent, pattern Name, fromName_, toName_, toModuleName_, fromModuleName_, fromName, toName,
	name_, moduleName_
	) where

import Control.Arrow
import Control.Lens
import Data.Char (isAlpha, isAlphaNum)
import Data.Text (Text)
import Data.String (fromString)
import qualified Data.Text as T
import Language.Haskell.Exts (QName(..), ModuleName(..), Boxed(..), SpecialCon(..))
import qualified Language.Haskell.Exts as Exts (Name(..))

-- | Qualified name
type Name = QName ()

qualName :: String -> String -> Name
qualName m = Qual () (ModuleName () m) . toName_ . fromString

unqualName :: String -> Name
unqualName = UnQual () . toName_ . fromString

nameModule :: Name -> Maybe Text
nameModule (Qual _ (ModuleName _ m) _) = Just $ fromString m
nameModule _ = Nothing

nameIdent :: Name -> Text
nameIdent (Qual _ _ n) = fromName_ n
nameIdent (UnQual _ n) = fromName_ n
nameIdent s = fromName s

pattern Name :: Maybe Text -> Text -> Name
pattern Name m n <- ((nameModule &&& nameIdent) -> (m, n)) where
	Name Nothing n = UnQual () (Exts.Ident () (T.unpack n))
	Name (Just m) n = Qual () (ModuleName () (T.unpack m)) (Exts.Ident () (T.unpack n))

fromName_ :: Exts.Name () -> Text
fromName_ (Exts.Ident _ s') = fromString s'
fromName_ (Exts.Symbol _ s') = fromString s'

toName_ :: Text -> Exts.Name ()
toName_ txt
	| T.null txt = Exts.Ident () ""
	| isAlpha (T.head txt) && (T.all validChar $ T.tail txt) = Exts.Ident () . T.unpack $ txt
	| otherwise = Exts.Symbol () . T.unpack $ txt
	where
		validChar ch = isAlphaNum ch || ch == '_'

toModuleName_ :: Text -> ModuleName ()
toModuleName_ = ModuleName () . T.unpack

fromModuleName_ :: ModuleName () -> Text
fromModuleName_ (ModuleName () m) = T.pack m

toName :: Text -> Name
toName "()" = Special () (UnitCon ())
toName "[]" = Special () (ListCon ())
toName "->" = Special () (FunCon ())
toName "(:)" = Special () (Cons ())
toName "(# #)" = Special () (UnboxedSingleCon ())
toName tup
	| T.all (== ',') noBraces = Special () (TupleCon () Boxed (succ $ T.length noBraces))
	where
		noBraces = T.dropAround (`elem` ['(', ')']) tup
toName n = case T.split (== '.') n of
	[n'] -> UnQual () (Exts.Ident () $ T.unpack n')
	ns -> Qual () (ModuleName () (T.unpack $ T.intercalate "." $ init ns)) (toName_ $ last ns)

fromName :: Name -> Text
fromName (Qual _ (ModuleName _ m) n) = T.concat [fromString m, ".", fromName_ n]
fromName (UnQual _ n) = fromName_ n
fromName (Special _ c) = case c of
	UnitCon _ -> "()"
	ListCon _ -> "[]"
	FunCon _ -> "->"
	TupleCon _ _ i -> fromString $ "(" ++ replicate (pred i) ',' ++ ")"
	Cons _ -> "(:)"
	UnboxedSingleCon _ -> "(# #)"
#if MIN_VERSION_haskell_src_exts(1,20,0)
	ExprHole _ -> "_"
#endif

name_ :: Iso' (Exts.Name ()) Text
name_ = iso fromName_ toName_

moduleName_ :: Iso' (ModuleName ()) Text
moduleName_ = iso fromModuleName_ toModuleName_