module DerivingDrift.Drift(driftDerive,driftResolvedNames) where
import Data.Char
import qualified Data.Map as Map
import DerivingDrift.DataP
import DerivingDrift.StandardRules
import FrontEnd.Class
import FrontEnd.HsParser
import FrontEnd.HsSyn
import FrontEnd.ParseMonad
import Name.Name
import Text.PrettyPrint.HughesPJ(render)
driftDerive :: HsModule -> [HsDecl]
driftDerive hsModule = if null ss then [] else hsModuleDecls hsMod
where
hsMod = case snd $ runParser parse ss of
ParseOk e -> e
ParseFailed sl err -> error $ "internal parse error(driftDerive): " ++ show sl ++ err ++ "\n" ++ ss
ss = unlines [ n | Just n <- map driftDerive' $ hsModuleDecls hsModule, any (not . isSpace) n ]
driftDerive' :: Monad m => HsDecl -> m String
driftDerive' HsDataDecl { hsDeclName = name, hsDeclArgs = args, hsDeclCons = condecls, hsDeclDerives = derives } = do
let d = unrenameTyVars $ toData name args condecls derives
isEnum = length condecls > 1 && null (concatMap hsConDeclArgs condecls)
xs <- return $ map (derive isEnum d) derives
return $ unlines xs
driftDerive' _ = fail "Nothing to derive"
unrenameTyVars :: Data -> Data
unrenameTyVars d = d{
vars = map (m Map.!) (vars d),
constraints = map (\(c,v) -> (c, m Map.! v)) (constraints d)
}
where m = Map.fromList $ zip (vars d) tyVars
tyVars = map (('a':) . show) [1::Int ..]
toData :: HsName -> [HsName] -> [HsConDecl] -> [HsName] -> Data
toData name args cons derives = ans where
f c = Body { constructor = pp (getIdent $ hsConDeclName c), types = hsConDeclArgs c, labels = lb c }
pp xs@(x:_) | isAlpha x = xs
pp xs = '(':xs++")"
lb HsConDecl {} = []
lb r = concatMap fst (hsConDeclRecArg r)
ans = D { statement = DataStmt, vars = map show args, constraints = [], name = name, derives = map show derives, body = map f cons }
derive True d wh | wh `elem` enumDerivableClasses ++ map toUnqualified enumDerivableClasses = "-- generated instance " ++ show wh ++ " " ++ getIdent (name d)
derive _ d wh | Just fn <- Map.lookup wh standardRules = render $ fn d
| Just _ <- Map.lookup (show wh) shortRuleNames = error (msg ++ " " ++ show wh ++ " not in scope.")
| otherwise = error msg
where msg = "Can't make a derived instance '" ++ show wh ++ " " ++ getIdent (name d) ++ "'."
shortRuleNames = Map.mapKeys getIdent standardRules