THMess.hs

type PrimParser = Parser Prim


mkParseFieldInstance :: Name -> DecsQ
mkParseFieldInstance name = do
    liftedName <- [| name |]
    alias <- getAlias name
    fieldParsers <- [| mkParserList name |] 
    case alias of
        Just x -> do
            liftedAlias <- [| x |]
            let aliasString = nameBase x ++ ":"
            fParser <- [|fieldParser |]
            pfromList <- [| primParserFromList |]
            let myBody =  NormalB ( 
                            AppE ( 
                                (AppE ( fParser ) 
                                    (LitE . stringL $ aliasString))) 
                                        (AppE pfromList fieldParsers)) -- Compiler (correctly) complains that I've given it a 'Q Parser' when it wants a 'Q exp' :-( 
            let myInstance = InstanceD Nothing [] (AppT (ConT ''ParseField) (ConT name)) [FunD 'parseP [Clause [] myBody []]]
            return [myInstance]
        Nothing -> do 

            fParsers <- [|fieldParser |]
            pfromList <- [| primParserFromList |]
            let myBody =  NormalB ((AppE ( fParsers ) ( AppE (LitE . stringL $ (map toLower) . nameBase $ name) (AppE pfromList fieldParsers))))
            let myInstance = InstanceD Nothing [] (AppT (ConT ''ParseField) (ConT name)) [FunD 'parseP [Clause [] myBody []]]
            return $ [myInstance]

fieldParser :: String -> Parser a -> Parser [a]
fieldParser str p = lexeme $ try $ do
    void $ lexeme $ string str
    spaces
    many1 p
    
primParserFromList :: [PrimParser] -> PrimParser
primParserFromList pList = foldr (<|>) alwaysFail pList 

mkParserList :: Name -> Q [PrimParser]
mkParserList name = do
    rawMap <- mkFieldParsers [] name
    let newMap = map (uncurry fieldString . (\ (x, y) -> (formatStrings x, y))) rawMap 
    return newMap
  where
      formatStrings :: [String] -> String
      formatStrings strs = (foldr (\sX sY -> sX ++ (if null sY then sY else "." ++ sY)) "" ) strs

formatStrings :: [String] -> String
formatStrings strs = (foldr (\sX sY -> sX ++ (if null sY then sY else "." ++ sY)) "" ) strs    


mkFieldParsers :: [String] -> Name -> Q [([String], PrimParser)]
mkFieldParsers acc name = do
    TyConI dec <- reify name
    case dec of
        DataD _c _n _bnd _k dCons _ -> case getPrimParser (ConT _n) of
            Just aParser -> return [(acc, aParser)]
            Nothing -> case length dCons of
                0 -> return [] 
                1 -> go False acc (head dCons)
                _ -> concatMapM (go False acc) dCons                   

        NewtypeD _ _ _ _ myCon _  -> (go True (acc) myCon)

        TySynD _ _ myTyp  -> mkField acc myTyp

        _                           -> fail $ "Unsupported data type. Only normal sum or product types are supported."

  where       
      go :: Bool -> [String] -> Con -> Q [([String], PrimParser)]
      go isNewtype acc3 con = case con of

                        NormalC myConName myBangs -> concatMapM  (\case 
                                        (Bang _ _, myTyp )  -> mkField (acc3 ++ [nameBase myConName]) myTyp) myBangs 

                        RecC recCName myRecordBangs -> concatMapM  (\case
                                        (recName,_, myTyp) -> mkField (if isNewtype then acc3 else acc3 ++ [show $ toLName recName]) myTyp) myRecordBangs

                        InfixC (_,a) myConName (_,b) -> concatMapM (mkField (acc3 ++ [nameBase myConName])) [a,b]

                        _  -> fail $ "Warning: Unsupported GADT or Existential type. Unable to create parsers."

      mkField :: [String] -> Type -> Q [([String], PrimParser)]
      mkField acc4 typ = case getPrimParser typ of
          Just aParser -> return $ [(acc4, aParser)]
          Nothing -> case typ of
                        ConT aName            -> mkFieldParsers acc4 aName
                        AppT t1 t2  -> if t1 == (ConT ''V.Vector) 
                            then case getPrimParser t2 of
                                        Just aParser -> return $ [(acc4, vector aParser)]
                                        Nothing -> mkField acc4 t2
                            else return []
                        _             -> return []