66 lines
2.4 KiB
Haskell
66 lines
2.4 KiB
Haskell
module Utils.PathPiece
|
|
( finiteFromPathPiece
|
|
, nullaryToPathPiece
|
|
, nullaryPathPiece
|
|
, splitCamel
|
|
, camelToPathPiece, camelToPathPiece'
|
|
) 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 Numeric.Natural
|
|
|
|
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|]) [] ]
|
|
]
|
|
|
|
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
|