{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{-
  Template Haskell generators and QuasiQuoters for Data.Label,
  separated out to conform to TH stage restriction.
 -}

module Data.Label.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Quote

-- valid label/type-tag letters
labels = ['_','\'']++['0'..'9']++['a'..'z']++['A'..'Z']

validLetters ""     = False
validLetters (l:ls) = l `elem` labels

-- one-value types (for valid letter ?): 
-- data L? = L?
-- instance Show L? where showsPrec _ _ = showString "?"

genLabelLetters cs = return $ concatMap genLabelLetter cs
  where genLabelLetter c = (DataD [] n [] [NormalC n []] []:
                            [InstanceD [] (AppT (ConT ''Show) (ConT n)) 
                             [FunD 'showsPrec [Clause [WildP,WildP] 
                              (NormalB (AppE (VarE 'showString) (LitE (StringL [c])))) []]]])
          where n = mkName ['L',c]

l = QuasiQuoter { quoteExp= parseLabelExp, quotePat= parseLabelPat }

-- [$l|label|] -> Ll :< La :< Lb :< Le :< Ll
parseLabelExp :: String -> Q Exp
parseLabelExp label | not (validLetters label) 
                    = error $ "Data.Label: "++label++" is not a valid label"
                    | otherwise
                    = return (foldr1 op (map (\c->ConE (mkName ("Data.Label.L"++[c]))) label))
  where a `op` b = InfixE (Just a) (ConE (mkName ":<")) (Just b)

-- [$l|label|] -> Ll :< La :< Lb :< Le :< Ll
parseLabelPat :: String -> Q Pat
parseLabelPat label | not (validLetters label) 
                    = error $ "Data.Label: "++label++" is not a valid label"
                    | otherwise
                    = return (foldr1 op (map (\c->ConP (mkName ("Data.Label.L"++[c])) []) label))
  where a `op` b = InfixP a (mkName ":<") b

-- type-level tags, without values (for valid letter ?): 
-- data T?
-- instance Show T? where showsPrec _ _ = showString "?"

genTypeTagLetters cs = return $ concatMap genTagLetter cs
  where genTagLetter c = DataD [] n [] [] [] :
                         [InstanceD [] (AppT (ConT ''Show) (ConT n)) 
                          [FunD 'showsPrec [Clause [WildP,WildP] 
                           (NormalB (AppE (VarE 'showString) (LitE (StringL [c])))) []]]]
          where n = mkName ['T',c]

-- no type-level quasiquoting:-<, support generating type synonyms instead
-- ($genTypeTag "Tag") -> type Tag = TT :. Ta :. Tg
-- won't work for lower case tags!
genTypeTag cs = return [TySynD (mkName cs) [] (foldr1 op (map (\c->ConT (mkName (['T',c]))) cs))]
  where a `op` b = AppT (AppT (ConT (mkName ":.")) a) b 

t = QuasiQuoter parseTypeTagExp parseTypeTagPat

-- [$t|tag|] -> undefined :: Tt :. Ta :. Tg
parseTypeTagExp :: String -> Q Exp
parseTypeTagExp tag | not (validLetters tag) 
                    = error $ "Data.Label: "++tag++" is not a valid type tag"
                    | otherwise
                    = return (SigE (VarE 'undefined)
                               (foldr1 op (map (\c->ConT (mkName ("Data.Label.T"++[c]))) tag)))
  where a `op` b = AppT (AppT (ConT (mkName ":.")) a) b 

-- [$t|tag|] -> _ :: Tt :. Ta :. Tg
parseTypeTagPat :: String -> Q Pat
parseTypeTagPat tag | not (validLetters tag) 
                    = error $ "Data.Label: "++tag++" is not a valid type tag"
                    | otherwise
                    = return (SigP WildP
                               (foldr1 op (map (\c->ConT (mkName ("Data.Label.T"++[c]))) tag)))
  where a `op` b = AppT (AppT (ConT (mkName ":.")) a) b