git.iko.soy/schematic
on 6cc400e help sign in
schematic/src/Data/Schematic/Verifier/Text.hs
118 lines 3.4 kB history raw
1module Data.Schematic.Verifier.Text where
3import Control.Monad
4import Data.Maybe
5import Data.Schematic
6import Data.Schematic.Verifier.Common
7import Data.Text (Text, unpack)
8import Text.Regex.TDFA.Pattern
9import Text.Regex.TDFA.ReadRegex (parseRegex)
11toStrictTextLength :: [DemotedTextConstraint] -> [DemotedTextConstraint]
12toStrictTextLength = map f
13 where
14 f (DTLe x) = DTLt (x + 1)
15 f (DTGe x) = DTGt (x - 1)
16 f x = x
18data VerifiedTextConstraint
19 = VTEq Integer
20 | VTBounds (Maybe Integer)
21 (Maybe Integer)
22 | VTRegex Text
23 Integer
24 (Maybe Integer)
25 | VTEnum [Text]
26 deriving (Show)
28verifyTextLengthConstraints ::
29 [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
30verifyTextLengthConstraints cs' = do
31 let cs = toStrictTextLength cs'
32 mlt = simplifyDNLs [x | DTLt x <- cs]
33 mgt = simplifyDNGs [x | DTGt x <- cs]
34 meq <- verifyDNEq [x | DTEq x <- cs]
35 verifyEquations mgt meq mlt
36 case all isNothing ([mgt, meq, mlt] :: [Maybe Integer]) of
37 True -> Just Nothing
38 _ ->
39 Just $
40 Just $
41 case meq of
42 Just eq -> VTEq eq
43 Nothing -> VTBounds mgt mlt
45regexLength :: Text -> Maybe (Int, Maybe Int)
46regexLength regexp =
47 case parseRegex . unpack $ regexp of
48 Right (p, _) -> Just (minRegexLength p, maxRegexLength p)
49 Left _ -> Nothing
51minRegexLength :: Pattern -> Int
52minRegexLength p =
53 case p of
54 PEmpty -> 0
55 PChar {..} -> 1
56 PAny {..} -> 1
57 PAnyNot {..} -> 1
58 PQuest _ -> 0
59 PPlus sch -> minRegexLength $ PBound 1 Nothing sch
60 PStar _ sch -> minRegexLength $ PBound 0 Nothing sch
61 PBound low _ sch -> low * minRegexLength sch
62 PConcat ps -> sum $ fmap minRegexLength ps
63 POr xs -> minimum $ fmap minRegexLength xs
64 PDot _ -> 1
65 PEscape {..} -> 1
66 PCarat _ -> 0
67 PDollar _ -> 0
68 _ -> 0
70maxRegexLength :: Pattern -> Maybe Int
71maxRegexLength p =
72 case p of
73 PEmpty -> Just 0
74 PChar _ _ -> Just 1
75 PAny _ _ -> Just 1
76 PAnyNot _ _ -> Just 1
77 PQuest _ -> Just 0
78 PPlus _ -> Nothing
79 PStar _ _ -> Nothing
80 PBound _ mhigh sch -> (*) <$> mhigh <*> maxRegexLength sch
81 PConcat ps -> sum <$> mapM maxRegexLength ps
82 POr xs -> maximum <$> mapM maxRegexLength xs
83 PDot _ -> Just 1
84 PEscape _ _ -> Just 1
85 PCarat _ -> Just 0
86 PDollar _ -> Just 0
87 _ -> Just 0
89verifyTextRegexConstraint ::
90 [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
91verifyTextRegexConstraint cs = do
92 let regexps = [x | DTRegex x <- cs]
93 case regexps of
94 [] -> Just Nothing
95 [x] -> do
96 (l, mh) <- regexLength x
97 Just $ Just $ VTRegex x (fromIntegral l) (fromIntegral <$> mh)
98 _ -> Nothing
100verifyTextEnumConstraint ::
101 [DemotedTextConstraint] -> Maybe (Maybe VerifiedTextConstraint)
102verifyTextEnumConstraint cs = do
103 let enums = concat [x | DTEnum x <- cs]
104 case enums of
105 [] -> Just Nothing
106 x -> Just $ Just $ VTEnum x
108verifyTextConstraints ::
109 [DemotedTextConstraint] -> Maybe [VerifiedTextConstraint]
110verifyTextConstraints cs = do
111 regexp <- verifyTextRegexConstraint cs
112 void $ case regexp of
113 Just (VTRegex _ l mh) ->
114 verifyTextLengthConstraints (DTGe l : cs ++ maybeToList (DTLe <$> mh))
115 _ -> pure Nothing
116 lengths <- verifyTextLengthConstraints cs
117 enums <- verifyTextEnumConstraint cs
118 return $ catMaybes [lengths, enums, regexp]