module Record
(
record,
lens,
r,
l,
)
where
import BasePrelude
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import qualified Record.Types as Types
import qualified Record.Lens as Lens
import qualified Record.Parser as Parser
import qualified Data.Text as T
r :: QuasiQuoter
r = record
l :: QuasiQuoter
l = lens
record :: QuasiQuoter
record =
QuasiQuoter
(exp)
(const $ fail "Pattern context is not supported")
(type')
(const $ fail "Declaration context is not supported")
where
exp =
join . fmap (either fail return . renderExp) .
either (fail . showString "Parser failure: ") return .
Parser.run (Parser.qq Parser.exp) . fromString
type' =
join . fmap (either fail return . renderType) .
either (fail . showString "Parser failure: ") return .
Parser.run (Parser.qq Parser.type') . fromString
lens :: QuasiQuoter
lens =
QuasiQuoter
(exp)
(const $ fail "Pattern context is not supported")
(const $ fail "Type context is not supported")
(const $ fail "Declaration context is not supported")
where
exp =
either (fail . showString "Parser failure: ") return .
fmap renderLens .
Parser.run (Parser.qq Parser.lens) . fromString
renderLens :: Parser.Lens -> Exp
renderLens =
foldl1 composition .
fmap renderSingleLens
where
composition a b =
UInfixE a (VarE '(.)) b
renderSingleLens :: T.Text -> Exp
renderSingleLens =
AppE (VarE 'Types.fieldLens) .
SigE (VarE 'undefined) .
AppT (ConT ''Types.FieldName) .
LitT . StrTyLit . T.unpack
renderRecordType :: Parser.RecordType -> Either String Type
renderRecordType l =
checkDuplicateLabels >> getRecordTypeName >>= constructType
where
checkDuplicateLabels =
maybe (return ()) (Left . showString "Duplicate labels: " . show) $
mfilter (not . null) . Just $
map (fst . head) $
filter ((> 1) . length) $
groupWith fst l
getRecordTypeName =
maybe (Left (showString "Record arity " . shows arity . shows " is not supported" $ ""))
(Right) $
recordTypeNameByArity arity
where
arity = length l
constructType n =
foldl (\a (l, t) -> AppT <$> (AppT <$> a <*> pure (textLitT l)) <*> (renderType t))
(pure (ConT n))
(sortWith fst l)
where
textLitT =
LitT . StrTyLit . T.unpack
recordTypeNameByArity :: Int -> Maybe Name
recordTypeNameByArity arity =
fmap head $ mfilter (not . null) $ Just $
drop (pred arity) $
[
''Types.Record1, ''Types.Record2, ''Types.Record3, ''Types.Record4,
''Types.Record5, ''Types.Record6, ''Types.Record7, ''Types.Record8,
''Types.Record9, ''Types.Record10, ''Types.Record11, ''Types.Record12,
''Types.Record12, ''Types.Record13, ''Types.Record14, ''Types.Record15,
''Types.Record16, ''Types.Record17, ''Types.Record18, ''Types.Record19,
''Types.Record20, ''Types.Record21, ''Types.Record22, ''Types.Record22,
''Types.Record23, ''Types.Record24
]
recordConNameByArity :: Int -> Maybe Name
recordConNameByArity arity =
fmap head $ mfilter (not . null) $ Just $
drop (pred arity) $
[
'Types.Record1, 'Types.Record2, 'Types.Record3, 'Types.Record4,
'Types.Record5, 'Types.Record6, 'Types.Record7, 'Types.Record8,
'Types.Record9, 'Types.Record10, 'Types.Record11, 'Types.Record12,
'Types.Record12, 'Types.Record13, 'Types.Record14, 'Types.Record15,
'Types.Record16, 'Types.Record17, 'Types.Record18, 'Types.Record19,
'Types.Record20, 'Types.Record21, 'Types.Record22, 'Types.Record22,
'Types.Record23, 'Types.Record24
]
renderType :: Parser.Type -> Either String Type
renderType =
\case
Parser.Type_App a b -> AppT <$> renderType a <*> renderType b
Parser.Type_Var n -> return $ VarT (mkName (T.unpack n))
Parser.Type_Con n -> return $ ConT (mkName (T.unpack n))
Parser.Type_Tuple a -> return $ TupleT a
Parser.Type_Arrow -> return $ ArrowT
Parser.Type_List -> return $ ListT
Parser.Type_Record a -> renderRecordType a
renderExp :: Parser.Exp -> Either String Exp
renderExp =
\case
Parser.Exp_Record r -> renderRecordExp r
Parser.Exp_Var n -> return $ VarE (mkName (T.unpack n))
Parser.Exp_Con n -> return $ ConE (mkName (T.unpack n))
Parser.Exp_TupleCon a -> return $ ConE (tupleDataName a)
Parser.Exp_Nil -> return $ ConE ('[])
Parser.Exp_Lit l -> return $ LitE (renderLit l)
Parser.Exp_App a b -> AppE <$> renderExp a <*> renderExp b
Parser.Exp_List l -> ListE <$> traverse renderExp l
Parser.Exp_Sig e t -> SigE <$> renderExp e <*> renderType t
renderRecordExp :: Parser.RecordExp -> Either String Exp
renderRecordExp l =
checkDuplicateLabels >> getConLambda >>= constructExp
where
checkDuplicateLabels =
maybe (return ()) (Left . showString "Duplicate labels: " . show) $
mfilter (not . null) . Just $
map (fst . head) $
filter ((> 1) . length) $
groupWith fst l
getConLambda =
maybe (Left (showString "Record arity " . shows arity . shows " is not supported" $ ""))
(Right) $
conLambdaExp arity
where
arity = length l
constructExp lam =
foldl (\a (n, e) -> AppE <$> (AppE <$> a <*> pure (proxy n)) <*> renderExp e)
(pure lam)
(sortWith fst l)
where
proxy n =
SigE (VarE 'undefined)
(AppT (ConT ''Types.FieldName) (LitT (StrTyLit (T.unpack n))))
renderLit :: Parser.Lit -> Lit
renderLit =
\case
Parser.Lit_Char c -> CharL c
Parser.Lit_String t -> StringL (T.unpack t)
Parser.Lit_Integer i -> IntegerL i
Parser.Lit_Rational r -> RationalL r
conLambdaExp :: Int -> Maybe Exp
conLambdaExp arity =
SigE <$> exp <*> t
where
exp =
LamE <$> pure pats <*> exp
where
pats =
concat $ flip map [1 .. arity] $ \i -> [WildP, VarP (mkName ("v" <> show i))]
exp =
foldl AppE <$> (ConE <$> recordConNameByArity arity) <*>
pure (map (\i -> VarE (mkName ("v" <> show i))) [1 .. arity])
t =
fnType <$> recordTypeNameByArity arity
where
fnType conName =
ForallT varBndrs [] $
foldr1 (\l r -> AppT (AppT ArrowT l) r)
(argTypes <> pure (resultType conName))
varBndrs =
concat $ flip map [1 .. arity] $ \i ->
PlainTV (mkName ("n" <> show i)) :
PlainTV (mkName ("v" <> show i)) :
[]
argTypes =
concat $ flip map [1 .. arity] $ \i ->
AppT (ConT ''Types.FieldName) (VarT (mkName ("n" <> show i))) :
VarT (mkName ("v" <> show i)) :
[]
resultType conName =
foldl AppT (ConT conName) $ concat $ flip map [1 .. arity] $ \i ->
VarT (mkName ("n" <> show i)) :
VarT (mkName ("v" <> show i)) :
[]