-
Notifications
You must be signed in to change notification settings - Fork 2
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Add
ToValue class to convert generated Haskell to Value
- Loading branch information
1 parent
0fdf52c
commit 724d473
Showing
4 changed files
with
173 additions
and
7 deletions.
There are no files selected for viewing
This file contains 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
This file contains 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
90 changes: 90 additions & 0 deletions
90
lib/fine-types/src/Language/FineTypes/Export/Haskell/Value/Compiletime.hs
This file contains 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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,90 @@ | ||
| -- | Export values of Haskell types to 'Value', generated at compile time. | ||
| module Language.FineTypes.Export.Haskell.Value.Compiletime | ||
| ( declareInstanceToValue | ||
| , declareToValueFunRecord | ||
| , declareToValueFunUnion | ||
| ) where | ||
|
|
||
| import Prelude | ||
|
|
||
| import Language.FineTypes.Export.Haskell.Language | ||
| ( Annotation, l, raiseFirstLetter, hsType ) | ||
| import Language.FineTypes.Typ | ||
| ( ConstructorName, FieldName, Typ, TypName ) | ||
|
|
||
| import qualified Language.Haskell.Exts as Hs | ||
|
|
||
| {----------------------------------------------------------------------------- | ||
| Compile time definitions | ||
| ------------------------------------------------------------------------------} | ||
| -- | Declare an @instance ToValue@ for a record type. | ||
| declareInstanceToValue | ||
| :: TypName | ||
| -> Hs.Decl Annotation | ||
| -> Hs.Decl Annotation | ||
| declareInstanceToValue name toValueDeclaration = | ||
| Hs.InstDecl l Nothing instanceRule (Just instanceDecls) | ||
| where | ||
| instanceRule = Hs.IRule l Nothing Nothing instanceHead | ||
| instanceHead = Hs.IHApp l (Hs.IHCon l className) (hsType name) | ||
| className = runtime "ToValue" | ||
| instanceDecls = [ Hs.InsDecl l toValueDeclaration ] | ||
|
|
||
| -- | Declare the funcion `toValue` for a record type. | ||
| declareToValueFunRecord | ||
| :: TypName | ||
| -> [(FieldName, Typ)] | ||
| -> Hs.Decl Annotation | ||
| declareToValueFunRecord constructor fields = | ||
| Hs.FunBind l | ||
| [ Hs.Match l (Hs.Ident l "toValue") [pat] rhs Nothing ] | ||
| where | ||
| pat = Hs.PApp l (Hs.UnQual l $ Hs.Ident l constructor) | ||
| [ Hs.PVar l (Hs.Ident l $ field <> "_pat") | ||
| | (field,_) <- fields | ||
| ] | ||
| rhs = Hs.UnGuardedRhs l $ productV `app` Hs.List l arguments | ||
| arguments = | ||
| [ Hs.Var l (runtime "toValue") `app` var (field <> "_pat") | ||
| | (field,_) <- fields | ||
| ] | ||
| productV = Hs.Con l (runtime "ProductV") | ||
|
|
||
| -- | Declare the funcion `toValue` for a sum type. | ||
| declareToValueFunUnion | ||
| :: TypName | ||
| -> [(ConstructorName, Typ)] | ||
| -> Hs.Decl Annotation | ||
| declareToValueFunUnion _ constructors = | ||
| Hs.FunBind l | ||
| [ Hs.Match l | ||
| (Hs.Ident l "toValue") | ||
| [pat constructor] | ||
| (rhs ix) | ||
| Nothing | ||
| | (ix,(constructor,_)) <- zip [0..] constructors | ||
| ] | ||
| where | ||
| pat constructor = | ||
| Hs.PApp l | ||
| (Hs.UnQual l $ Hs.Ident l $ raiseFirstLetter constructor) | ||
| [ Hs.PVar l (Hs.Ident l "x") ] | ||
| rhs ix = Hs.UnGuardedRhs l $ | ||
| (sumV `app` int ix) | ||
| `app` (Hs.Var l (runtime "toValue") `app` var "x") | ||
| int ix = Hs.Lit l $ Hs.Int l ix (show ix) | ||
| sumV = Hs.Con l (runtime "SumV") | ||
|
|
||
| {----------------------------------------------------------------------------- | ||
| Expression utilities | ||
| ------------------------------------------------------------------------------} | ||
| app :: Hs.Exp Annotation -> Hs.Exp Annotation -> Hs.Exp Annotation | ||
| app = Hs.App l | ||
|
|
||
| runtime :: String -> Hs.QName Annotation | ||
| runtime | ||
| = Hs.Qual l (Hs.ModuleName l "Export.Haskell.Value.Runtime") | ||
| . Hs.Ident l | ||
|
|
||
| var :: String -> Hs.Exp Annotation | ||
| var = Hs.Var l . Hs.UnQual l . Hs.Ident l |
60 changes: 60 additions & 0 deletions
60
lib/fine-types/src/Language/FineTypes/Export/Haskell/Value/Runtime.hs
This file contains 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
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,60 @@ | ||
| {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} | ||
| {-# HLINT ignore "Use bimap" #-} | ||
| -- | Export values of Haskell types to 'Value'. | ||
| module Language.FineTypes.Export.Haskell.Value.Runtime | ||
| ( ToValue (..) | ||
| , V.Value (..) | ||
| ) where | ||
|
|
||
| import Prelude ((.)) | ||
|
|
||
| import qualified Language.FineTypes.Value as V | ||
|
|
||
| import qualified Data.ByteString | ||
| import qualified Data.Map | ||
| import qualified Data.Set | ||
| import qualified Data.Text | ||
| import qualified Numeric.Natural | ||
| import qualified Prelude | ||
|
|
||
| {----------------------------------------------------------------------------- | ||
| Runtime definitions | ||
| ------------------------------------------------------------------------------} | ||
| -- | Class of types that can be converted to 'Value'. | ||
| -- | ||
| -- Note: The 'Ord' constraint is necessary to deal with 'Set'. | ||
| class Prelude.Ord a => ToValue a where | ||
| toValue :: a -> V.Value | ||
|
|
||
| z :: V.ZeroF -> V.Value | ||
| z = V.Zero | ||
|
|
||
| instance ToValue Prelude.Bool where toValue = z . V.Bool | ||
| instance ToValue Data.ByteString.ByteString where toValue = z . V.Bytes | ||
| instance ToValue Prelude.Integer where toValue = z . V.Integer | ||
| instance ToValue Numeric.Natural.Natural where toValue = z . V.Natural | ||
| instance ToValue Data.Text.Text where toValue = z . V.Text | ||
| instance ToValue () where toValue _ = z V.Unit | ||
|
|
||
| instance ToValue a => ToValue (Prelude.Maybe a) where | ||
| toValue = V.One . V.Option . Prelude.fmap toValue | ||
|
|
||
| instance ToValue a => ToValue [a] where | ||
| toValue = V.One . V.Sequence . Prelude.fmap toValue | ||
|
|
||
| instance ToValue a => ToValue (Data.Set.Set a) where | ||
| toValue = V.One . V.PowerSet . Data.Set.map toValue | ||
|
|
||
| instance (ToValue a, ToValue b) => ToValue (Prelude.Either a b) where | ||
| toValue (Prelude.Left a) = V.Sum 0 (toValue a) | ||
| toValue (Prelude.Right b) = V.Sum 1 (toValue b) | ||
|
|
||
| instance (ToValue a, ToValue b) => ToValue (a,b) where | ||
| toValue (a,b) = V.Product [toValue a, toValue b] | ||
|
|
||
| instance (ToValue a, ToValue b) => ToValue (Data.Map.Map a b) where | ||
| toValue | ||
| = V.Two . V.FiniteMap | ||
| . Data.Map.fromList | ||
| . Prelude.map (\(k,v) -> (toValue k, toValue v)) | ||
| . Data.Map.toList |