Created
May 26, 2020 12:42
-
-
Save ners/46cebb66a3c8db8f908b13aba1872bee to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE AllowAmbiguousTypes #-} | |
| {-# LANGUAGE ExistentialQuantification #-} | |
| {-# LANGUAGE RankNTypes #-} | |
| {-# LANGUAGE ScopedTypeVariables #-} | |
| import Control.Arrow ( (&&&) ) | |
| import Data.Data | |
| ( ConstrRep (AlgConstr) | |
| , Data | |
| , cast | |
| , constrFields | |
| , constrRep | |
| , gfoldl | |
| , gmapQi | |
| , toConstr | |
| ) | |
| import Data.Default ( Default, def ) | |
| import Data.Either ( Either, either ) | |
| import Data.Generics ( extQ, extT ) | |
| import Data.List ( elemIndex ) | |
| import Data.Maybe ( Maybe, fromJust ) | |
| import Data.Typeable ( Typeable, typeOf ) | |
| data Error | |
| = NotRecord | |
| | FieldNotFound String | |
| | forall x y. (Typeable x, Typeable y) => | |
| FieldTypeMismatch String x y | |
| instance Show Error where | |
| show NotRecord = "Not a record type" | |
| show (FieldNotFound fieldName) = "Field " ++ fieldName ++ " does not exist" | |
| show (FieldTypeMismatch fieldName x y) = | |
| "Field type mismatch: " ++ fieldName ++ " :: " ++ show (typeOf x) ++ ", got " ++ show (typeOf y) | |
| data Ti a = | |
| Ti Int a | |
| gmapTi :: Data a => Int -> (forall b . Data b => b -> b) -> a -> a | |
| gmapTi i f x = case gfoldl k z x of | |
| Ti _ a -> a | |
| where | |
| k :: Data d => Ti (d -> b) -> d -> Ti b | |
| k (Ti i' c) a = Ti (i' + 1) (if i == i' then c (f a) else c a) | |
| z :: g -> Ti g | |
| z = Ti 0 | |
| fieldNames :: Data r => r -> Either Error [String] | |
| fieldNames rec = case (constrRep &&& constrFields) $ toConstr rec of | |
| (AlgConstr _, fs) | not $ null fs -> Right fs | |
| _ -> Left NotRecord | |
| fieldIndex :: Data r => String -> r -> Either Error Int | |
| fieldIndex fieldName rec = | |
| fieldNames rec >>= \fns -> maybe (Left $ FieldNotFound fieldName) Right $ fieldName `elemIndex` fns | |
| modifyField :: (Data r, Typeable v) => String -> (v -> v) -> r -> Either Error r | |
| modifyField fieldName m rec = fieldIndex fieldName rec >>= \i -> gmapTi i (e `extT` m) rec | |
| where e x = Left $ FieldTypeMismatch fieldName x (m undefined) | |
| create :: (Data r, Default r, Typeable v) => [(String, v)] -> Either Error r | |
| create = foldr (\(n, v) r -> setField n v <$> r) (Right def) | |
| create' :: (Data r, Default r, Typeable v) => [(String, v)] -> r | |
| create' = foldr (\(n, v) r -> either (const r) id $ setField n v r) def | |
| setField :: (Data r, Typeable v) => String -> v -> r -> Either Error r | |
| setField fieldName value = modifyField fieldName (const value) | |
| getField :: (Data r, Typeable v) => String -> r -> Either Error v | |
| getField fieldName rec = fieldIndex fieldName rec >>= \i -> gmapQi i (e `extQ` Right) rec | |
| where e x = Left $ FieldTypeMismatch fieldName x (e undefined) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment