File: Patterns.hs

package info (click to toggle)
haskell-cryptol 2.8.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 1,644 kB
  • sloc: haskell: 20,847; yacc: 652; makefile: 5
file content (137 lines) | stat: -rw-r--r-- 3,540 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
{-# Language Safe, RankNTypes, MultiParamTypeClasses #-}
{-# Language FunctionalDependencies #-}
{-# Language FlexibleInstances #-}
{-# Language TypeFamilies, UndecidableInstances #-}
module Cryptol.Utils.Patterns where

import Control.Monad(liftM,liftM2,ap,MonadPlus(..),guard)
import Control.Applicative(Alternative(..))

newtype Match b = Match (forall r. r -> (b -> r) -> r)

instance Functor Match where
  fmap = liftM

instance Applicative Match where
  pure a = Match $ \_no yes -> yes a
  (<*>)  = ap

instance Monad Match where
  Match m >>= f = Match $ \no yes -> m no $ \a ->
                                     let Match n = f a in
                                     n no yes
instance MonadFail Match where
  fail _ = empty

instance Alternative Match where
  empty = Match $ \no _ -> no
  Match m <|> Match n = Match $ \no yes -> m (n no yes) yes

instance MonadPlus Match where

type Pat a b = a -> Match b


(|||) :: Pat a b -> Pat a b -> Pat a b
p ||| q = \a -> p a <|> q a

-- | Check that a value satisfies multiple patterns.
-- For example, an "as" pattern is @(__ &&& p)@.
(&&&) :: Pat a b -> Pat a c -> Pat a (b,c)
p &&& q = \a -> liftM2 (,) (p a) (q a)

-- | Match a value, and modify the result.
(~>) :: Pat a b -> (b -> c) -> Pat a c
p ~> f = \a -> f <$> p a

-- | Match a value, and return the given result
(~~>) :: Pat a b -> c -> Pat a c
p ~~> f = \a -> f <$ p a

-- | View pattern.
(<~) :: (a -> b) -> Pat b c -> Pat a c
f <~ p = \a -> p (f a)

-- | Variable pattern.
__ :: Pat a a
__ = return

-- | Constant pattern.
succeed :: a -> Pat x a
succeed = const . return

-- | Predicate pattern
checkThat :: (a -> Bool) -> Pat a ()
checkThat p = \a -> guard (p a)

-- | Check for exact value.
lit :: Eq a => a -> Pat a ()
lit x = checkThat (x ==)
{-# Inline lit #-}


-- | Match a pattern, using the given default if valure.
matchDefault :: a -> Match a -> a
matchDefault a (Match m) = m a id
{-# Inline matchDefault #-}

-- | Match an irrefutable pattern.  Crashes on faliure.
match :: Match a -> a
match m = matchDefault (error "Pattern match failure.") m
{-# Inline match #-}

matchMaybe :: Match a -> Maybe a
matchMaybe (Match m) = m Nothing Just


list :: [Pat a b] -> Pat [a] [b]
list [] = \a ->
  case a of
    [] -> return []
    _  -> mzero
list (p : ps) = \as ->
  case as of
    []     -> mzero
    x : xs ->
      do a  <- p x
         bs <- list ps xs
         return (a : bs)


(><) :: Pat a b -> Pat x y -> Pat (a,x) (b,y)
p >< q = \(a,x) -> do b <- p a
                      y <- q x
                      return (b,y)

class Matches thing pats res | pats -> thing res where
  matches :: thing -> pats -> Match res

instance ( f  ~ Pat a a1'
         , a1 ~ Pat a1' r1
         ) => Matches a (f,a1) r1 where
  matches ty (f,a1) = do a1' <- f ty
                         a1 a1'

instance ( op ~ Pat a (a1',a2')
         , a1 ~ Pat a1' r1
         , a2 ~ Pat a2' r2
         ) => Matches a (op,a1,a2) (r1,r2)
  where
  matches ty (f,a1,a2) = do (a1',a2') <- f ty
                            r1 <- a1 a1'
                            r2 <- a2 a2'
                            return (r1,r2)

instance ( op ~ Pat a (a1',a2',a3')
         , a1 ~ Pat a1' r1
         , a2 ~ Pat a2' r2
         , a3 ~ Pat a3' r3
         ) => Matches a (op,a1,a2,a3) (r1,r2,r3) where
  matches ty (f,a1,a2,a3) = do (a1',a2',a3') <- f ty
                               r1 <- a1 a1'
                               r2 <- a2 a2'
                               r3 <- a3 a3'
                               return (r1,r2,r3)