module Parse.Internal.Instances where

import Control.Monad
import Data.List.Split (splitOn)
import Language.Haskell.TH

-- Dear future self,
-- You're looking at this file because the parseTupleInstance function finally broke.
-- It's not fixable. You have to rewrite it.
-- Sincerely, past self.

class ParseTuple a where
  parseTuple :: String -> String -> Either String a

parseTupleInstance :: Int -> Q Dec
parseTupleInstance :: Int -> Q Dec
parseTupleInstance Int
n = do
  Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$
    String -> Q ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q ()) -> String -> Q ()
forall a b. (a -> b) -> a -> b
$ String
"Non-positive size: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n

  Exp
doParse <- [|parseParts (splitOn "{}" format) str|]
  Pat
invalidLengthL <- [p|Right result|]
  Exp
invalidLengthR <- [|Left $ "Parsed " ++ show (length result) ++ " values, expected " ++
                      show n ++ "."|]
  Pat
parseErrorL <- [p|Left x|]
  Exp
parseErrorR <- [|Left x|]

  let vars :: [Name]
vars = [String -> Name
mkName (Char
't' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n) | Int
n <- [Int
1..Int
n]]
      tupleSignature :: Type
tupleSignature = (Type -> Name -> Type) -> Type -> [Name] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Type
acc Name
var -> Type -> Type -> Type
AppT Type
acc (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"String")) (Int -> Type
TupleT Int
n) [Name]
vars
        -- foldl (\acc var -> AppT acc (VarT var)) (TupleT n) vars
      parseList :: Pat
parseList = [Pat] -> Pat
ListP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
VarP [Name]
vars
      parse :: Exp
parse = [Maybe Exp] -> Exp
TupE ([Maybe Exp] -> Exp) -> [Maybe Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Maybe Exp) -> [Name] -> [Maybe Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> (Name -> Exp) -> Name -> Maybe Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. -- AppE (VarE $ mkName "read")
                          Name -> Exp
VarE) [Name]
vars
      -- context = map (AppT (ConT $ mkName "Read") . VarT) vars
      iDecl :: Dec
iDecl = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] -- context
              (Type -> Type -> Type
AppT (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"ParseTuple") Type
tupleSignature) [Dec
parseDecl]
      parseDecl :: Dec
parseDecl =
        -- `parseTuple` function
        Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
"parseTuple")
        -- only has one clause
        [[Pat] -> Body -> [Dec] -> Clause
Clause
          -- Arguments: format and str
          [Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"format", Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"str"]
          -- Body
          (Exp -> Body
NormalB
           (Exp -> [Match] -> Exp
CaseE Exp
doParse
           [ Pat -> Body -> [Dec] -> Match
Match (Name -> [Pat] -> Pat
ConP (String -> Name
mkName String
"Right") [Pat
parseList])
                   (Exp -> Body
NormalB (Exp -> Exp -> Exp
AppE (Name -> Exp
ConE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Right") Exp
parse)) []
           , Pat -> Body -> [Dec] -> Match
Match Pat
invalidLengthL (Exp -> Body
NormalB Exp
invalidLengthR) []
           , Pat -> Body -> [Dec] -> Match
Match Pat
parseErrorL (Exp -> Body
NormalB Exp
parseErrorR) [] ]))
          -- Where
          []]

  Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
iDecl

parseTupleInstances :: [Int] -> Q [Dec]
parseTupleInstances :: [Int] -> Q [Dec]
parseTupleInstances = (Int -> Q Dec) -> [Int] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Int -> Q Dec
parseTupleInstance