0 | module Derive.Sqlite3.FromCell
 1 |
 2 | import Sqlite3.Marshall
 3 | import Sqlite3.Types
 4 | import Language.Reflection.Util
 5 |
 6 | %default total
 7 |
 8 | --------------------------------------------------------------------------------
 9 | --          Claims
10 | --------------------------------------------------------------------------------
11 |
12 | cellType : Vect n Name -> ParamCon n -> Maybe TTImp
13 | cellType vs (MkParamCon _ _ args) =
14 |   case mapMaybe convert $ toList args of
15 |     [t] => Just `(FromCellType ~(t))
16 |     _   => Nothing
17 |   where
18 |     convert : ConArg n -> Maybe TTImp
19 |     convert (CArg _ MW _ t) = Just $ ttimp vs t
20 |     convert _               = Nothing
21 |
22 | ||| Top-level declaration of the `FromCell` implementation
23 | ||| for the given data type.
24 | export
25 | fromCellImplClaim : (impl : Name) -> (p : ParamTypeInfo) -> Decl
26 | fromCellImplClaim impl p = implClaim impl (implType "FromCell" p)
27 |
28 | --------------------------------------------------------------------------------
29 | --          Definitions
30 | --------------------------------------------------------------------------------
31 |
32 | x : Name
33 | x = "x"
34 |
35 | parameters (nms : List Name)
36 |   decEnumClause : Con n vs -> Clause
37 |   decEnumClause c = patClause c.namePrim `(Right ~(var c.name))
38 |
39 |   decEnum : TypeInfo -> TTImp
40 |   decEnum ti = `(decodeJust ~(ti.namePrim) ~(dec))
41 |     where
42 |       catchAll : TTImp
43 |       catchAll = `(Left $ DecodingError TEXT ~(ti.namePrim))
44 |
45 |       dec : TTImp
46 |       dec =
47 |         lam (lambdaArg x) $
48 |         iCase (var x) `(String) $
49 |           map decEnumClause ti.cons ++ [patClause implicitTrue catchAll]
50 |
51 |   fromCellEnumDef : Name -> TypeInfo -> Decl
52 |   fromCellEnumDef f ti =
53 |     def f [patClause (var f) `(MkFromCell TEXT ~(decEnum ti))]
54 |
55 |   decNewtype : ParamCon n -> TTImp
56 |   decNewtype c = `(map ~(var c.name) . fromCell)
57 |
58 |   fromCellNewtypeDef : Name -> TTImp -> ParamCon n -> Decl
59 |   fromCellNewtypeDef f ct c =
60 |     def f [patClause (var f) `(MkFromCell ~(ct) ~(decNewtype c))]
61 |
62 | --------------------------------------------------------------------------------
63 | --          Deriving
64 | --------------------------------------------------------------------------------
65 |
66 | ||| Generate declarations and implementations for `ToJSON` for a given data type
67 | ||| using default settings.
68 | export %inline
69 | FromCell : List Name -> ParamTypeInfo -> Res (List TopLevel)
70 | FromCell nms p =
71 |  let impl := implName p "FromCell"
72 |   in if isEnum p.info
73 |         then
74 |           Right [ TL (fromCellImplClaim impl p) (fromCellEnumDef nms impl p.info) ]
75 |      else
76 |        case p.cons of
77 |          [c] =>
78 |             case cellType p.paramNames c of
79 |               Just ct => Right [ TL (fromCellImplClaim impl p) (fromCellNewtypeDef nms impl ct c) ]
80 |               Nothing => Left "Interface FromCell can only be derived for enumerations and newtypes."
81 |          _   => Left "Interface FromCell can only be derived for enumerations and newtypes."
82 |