module Language.Haskell.Meta.QQ.ADo (
ado,
ado'
) where
import Control.Applicative
import Language.Haskell.Meta
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Control.Monad
import qualified Data.Set as S
import Language.Haskell.Meta.Utils (cleanNames)
import Data.Generics
ado :: QuasiQuoter
ado = ado'' False
ado' :: QuasiQuoter
ado' = ado'' True
ado'' :: Bool -> QuasiQuoter
ado'' b = QuasiQuoter
(\str -> fmap cleanNames $ applicate b =<< parseDo str)
(either fail return . parsePat)
parseDo :: (Monad m) => String -> m [Stmt]
parseDo str =
let prefix = "do\n" in
case parseExp $ prefix ++ str of
Right (DoE stmts) -> return stmts
Right a -> fail $ "ado can't handle:\n" ++ show a
Left a -> fail a
applicate :: Bool -> [Stmt] -> ExpQ
applicate rawPatterns stmt = do
(_:ps,f:es) <- fmap (unzip . reverse) $
flip mapM stmt $ \s ->
case s of
BindS p e -> return (p,e)
NoBindS e -> return (WildP,e)
LetS _ -> fail $ "LetS not supported"
ParS _ -> fail $ "ParS not supported"
fps <- failingPatterns ps
f' <- case filter (not . snd) $ zip ps fps of
[] -> return $ LamE ps f
_ | rawPatterns -> return $ LamE ps f
| otherwise -> do
xs <- mapM (const $ newName "x") ps
return $ LamE (map VarP xs) $ CaseE (TupE (map VarE xs))
[Match (TupP ps) (NormalB $ ConE 'Just `AppE` f) []
,Match WildP (NormalB $ ConE 'Nothing) []
]
return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g)
(VarE 'pure `AppE` f')
es
failingPatterns :: (Data a) => [a] -> Q [Bool]
failingPatterns ps = flip mapM ps $ \p ->
let couldFail x = liftM not (singleCon x)
constrs :: Data a => a -> S.Set Name
constrs = S.fromList . map (\(ConP n _) -> n)
. listify (\x -> case x of ConP {} -> True; _ -> False)
irrefutables = constrs
. listify (\x -> case x of TildeP {} -> True; _ -> False)
in liftM null $ filterM couldFail $ S.elems $
constrs p S.\\ irrefutables p
singleCon :: Name -> Q Bool
singleCon n = do
DataConI _ _ tn _ <- reify n
TyConI dec <- reify tn
case dec of
DataD _ _ _ [_] _ -> return True
NewtypeD {} -> return True
DataD _ _ _ (_:_) _ -> return False
_ -> fail $ "Bad dec: "++show dec