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
import Data.Registry | |
data Company = Company [Department] deriving (Eq, Show) | |
data Departement = Department [PersonV0] deriving (Eq, Show) | |
data PersonV0 = PersonV0 Text deriving (Eq, Show) | |
data PersonV1 = PersonV1 Text Int deriving (Eq, Show) | |
-- A registry for a given "schema". That registry can be lifted to | |
-- any Applicative context: Encoder, Decoder, Gen, ... |
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
-- a component | |
data FileSystem m = FileSystem { | |
exists :: Path -> m (Either Text Bool) | |
, readFile :: Path -> m (Either Text Text) | |
} | |
-- a constructor for a mock file system | |
newFileSystemWith :: (FileSystemValues -> FileSystemValues) -> FileSystem | |
newFileSystemWith f = FileSystem { | |
exists = \_ -> pure (_exists $ f fileSystemValues) |
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
data Expr = | |
Var String | |
| Lam String Expr | |
| App Expr Expr |
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
test_cycle_constructors = | |
prop "we can cycle deterministically across all the constructors of a data type" $ runS generators $ do | |
setGenS @Int (pure 1) | |
setCycleChooserS @EmployeeStatus | |
names <- replicateM 10 (forallS @EmployeeStatus) | |
names === take 10 (join $ repeat [Permanent, Temporary 1]) |
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
test_with_better_department_name = | |
prop "a department must have a short capitalized name" $ runS generators $ do | |
setSmallCompany | |
setDepartmentName | |
company <- forallS @Company | |
let Just d = head $ departments company | |
(T.length (departmentName d) <= 5) === True |
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
setShortDepartmentNamesS :: MonadState (Registry _ _) m => m () | |
setShortDepartmentNamesS = specializeGenS @Department genDepartmentName |
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
-- short and upper cased names | |
genDepartmentName = T.take 5 . T.toUpper <$> genText | |
registry' = | |
specializeGen @Department genDepartmentName | |
registry | |
-- we get specific department names | |
λ> fmap departmentName <$> (replicateM 5 $ sampleIO (make @(GenIO Department) registry')) | |
["CE","UNZ","FG","V","HIB"] |
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
registry' = | |
fun (list @Deparment (linear 10 1000)) | |
<: registry |
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
registry' = | |
genVal (pure Permanent) | |
<: registry | |
permanentCompany :: GenIO Company | |
permanentCompany = make registry' | |
λ> replicateM 5 $ sampleIO (make @(GenIO EmployeeStatus) registry') | |
[Permanent,Permanent,Permanent,Permanent,Permanent] |
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
fun genEmployeeStatus | |
<: genFun (tag @"permanent" Permanent) -- Gen (Tag "permanent" EmployeeStatus) | |
<: genFun (tag @"temporary" Temporary) -- Gen (Tag "temporary" EmployeeStatus) | |
genEmployeeStatus :: | |
GenIO (Tag "permanent" EmployeeStatus) | |
-> GenIO (Tag "temporary" EmployeeStatus) | |
-> GenIO EmployeeStatus | |
genEmployeeStatus g1 g2 = Gen.choice [fmap unTagg1, fmap unTag g2] |