125 lines
4.4 KiB
Haskell
125 lines
4.4 KiB
Haskell
module Utils.PathPiece
|
||
( finiteFromPathPiece
|
||
, nullaryToPathPiece
|
||
, nullaryPathPiece, finitePathPiece
|
||
, splitCamel
|
||
, camelToPathPiece, camelToPathPiece'
|
||
, tuplePathPiece
|
||
, pathPieceJSONKey
|
||
) where
|
||
|
||
import ClassyPrelude.Yesod
|
||
|
||
import Language.Haskell.TH
|
||
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
|
||
import Data.Universe
|
||
|
||
import qualified Data.Text as Text
|
||
import qualified Data.Char as Char
|
||
|
||
import Data.Map ((!), (!?))
|
||
import qualified Data.Map as Map
|
||
|
||
import Numeric.Natural
|
||
|
||
import Data.List (foldl)
|
||
|
||
import Data.Aeson.Types
|
||
|
||
|
||
finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
|
||
finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
|
||
[x] -> Just x
|
||
_xs -> Nothing
|
||
|
||
nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
|
||
nullaryToPathPiece nullaryType ((. Text.pack) -> mangle) = do
|
||
TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
|
||
helperName <- newName "helper"
|
||
let
|
||
toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) []
|
||
toClause con = fail $ "Unsupported constructor: " ++ show con
|
||
helperDec = funD helperName $ map toClause constructors
|
||
letE [helperDec] $ varE helperName
|
||
|
||
nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
|
||
nullaryPathPiece nullaryType mangle =
|
||
pure <$> instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
|
||
[ funD 'toPathPiece
|
||
[ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
|
||
, funD 'fromPathPiece
|
||
[ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
|
||
]
|
||
|
||
finitePathPiece :: Name -> [Text] -> DecsQ
|
||
finitePathPiece finiteType verbs =
|
||
pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
|
||
[ funD 'toPathPiece
|
||
[ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
|
||
, funD 'fromPathPiece
|
||
[ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ]
|
||
]
|
||
|
||
|
||
splitCamel :: Textual t => t -> [t]
|
||
splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
|
||
where
|
||
helper _hadChange items thisWord [] = reverse thisWord : items
|
||
helper _hadChange items [] (c:cs) = helper True items [c] cs
|
||
helper hadChange items ws@(w:ws') (c:cs)
|
||
| sameCategory w c
|
||
, null ws' = helper (Char.isLower w) items (c:ws) cs
|
||
| sameCategory w c = helper hadChange items (c:ws) cs
|
||
| Char.isLower w
|
||
, Char.isUpper c = helper True (reverse ws :items) [c] cs
|
||
| null ws' = helper True items (c:ws) cs
|
||
| not hadChange = helper True (reverse ws':items) [c,w] cs
|
||
| otherwise = helper True (reverse ws :items) [c] cs
|
||
|
||
sameCategory = (==) `on` Char.generalCategory
|
||
|
||
camelToPathPiece' :: Textual t => Natural -> t -> t
|
||
camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dropN) . splitCamel
|
||
|
||
camelToPathPiece :: Textual t => t -> t
|
||
camelToPathPiece = camelToPathPiece' 0
|
||
|
||
|
||
tuplePathPiece :: Int -> DecQ
|
||
tuplePathPiece tupleDim = do
|
||
let
|
||
tupleSeparator :: Text
|
||
tupleSeparator = ","
|
||
|
||
xs <- replicateM tupleDim $ newName "x" :: Q [Name]
|
||
xs' <- replicateM tupleDim $ newName "x'" :: Q [Name]
|
||
|
||
let tupleType = foldl appT (tupleT tupleDim) $ map varT xs
|
||
tCxt = cxt
|
||
[ [t|PathPiece $(varT x)|] | x <- xs ]
|
||
|
||
t <- newName "t"
|
||
|
||
instanceD tCxt [t|PathPiece $(tupleType)|]
|
||
[ funD 'toPathPiece
|
||
[ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
|
||
]
|
||
, funD 'fromPathPiece
|
||
[ clause [varP t] (normalB . doE $ concat
|
||
[ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
|
||
, [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
|
||
, pure $ noBindS [e|return $(tupE $ map varE xs')|]
|
||
]) []
|
||
]
|
||
]
|
||
|
||
|
||
pathPieceJSONKey :: Name -> DecsQ
|
||
-- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance
|
||
pathPieceJSONKey tName
|
||
= [d| instance ToJSONKey $(conT tName) where
|
||
toJSONKey = toJSONKeyText toPathPiece
|
||
instance FromJSONKey $(conT tName) where
|
||
fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t
|
||
|]
|