module Control.Applicative.QQ.ADo (
ado,
ado'
) where
import Control.Applicative
import Language.Haskell.Meta (parseExp)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Control.Monad
ado :: QuasiQuoter
ado = ado'' False
ado' :: QuasiQuoter
ado' = ado'' True
ado'' :: Bool -> QuasiQuoter
ado'' b = QuasiQuoter { quoteExp = \str -> applicate b =<< parseDo str,
quotePat = nonsense "pattern",
quoteType = nonsense "type",
quoteDec = nonsense "declaration" }
where
nonsense context = fail $ "You can't use ado in " ++ context ++
" context, that doesn't even make sense."
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"
b <- if rawPatterns then return True else null <$> filterM failingPattern ps
f' <- if b
then return $ LamE ps f
else 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
failingPattern :: Pat -> Q Bool
failingPattern pat = case pat of
VarP {} -> return False
TildeP {} -> return False
WildP -> return False
LitP {} -> return True
ListP {} -> return True
ConP n ps -> liftM2 (\x y -> not x || y) (singleCon n) (anyFailing ps)
InfixP p n q -> failingPattern $ ConP n [p, q]
UInfixP p n q -> failingPattern $ ConP n [p, q]
RecP n fps -> failingPattern $ ConP n (map snd fps)
TupP ps -> anyFailing ps
UnboxedTupP ps -> anyFailing ps
ParensP p -> failingPattern p
BangP p -> failingPattern p
AsP _ p -> failingPattern p
SigP p _ -> failingPattern p
ViewP _ p -> failingPattern p
where
anyFailing = fmap or . mapM failingPattern
singleCon :: Name -> Q Bool
singleCon n = do
dec <- recover noScope $ do
Just vn <- lookupValueName (show n)
DataConI _ _ tn _ <- reify vn
TyConI dec <- reify tn
return dec
case dec of
DataD _ _ _ [_] _ -> return True
NewtypeD {} -> return True
DataD _ _ _ (_:_) _ -> return False
_ -> fail $ "ado singleCon: not a data declaration: " ++ show dec
where
noScope = fail $ "Data constructor " ++ show n ++ " lookup failed."