git.iko.soy/rowtype-yoga/purescript-native
on 294b01d help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen/Common.hs
79 lines 2.8 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.CodeGen.Common
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
17module PureScript.CodeGen.Common where
19import Data.Maybe (fromMaybe)
20import Data.List (nub, intersperse, intercalate)
21import Data.Function (fix)
22import Control.Monad.State
23import Control.Applicative (Applicative(..), Alternative(..))
24import qualified Control.Category as C
25import Control.Category ((>>>))
26import qualified Control.Arrow as A
27import Control.Arrow ((***))
29import PureScript.Values
30import PureScript.Types
31import PureScript.Declarations
33newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)
35pattern :: Pattern a b -> a -> Maybe b
36pattern = A.runKleisli . runPattern
38instance Functor (Pattern a) where
39 fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p
41instance Applicative (Pattern a) where
42 pure = Pattern . A.Kleisli . const . pure
43 f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a
45instance Alternative (Pattern a) where
46 empty = Pattern $ A.Kleisli $ \a -> empty
47 (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a
49parens :: String -> String
50parens s = ('(':s) ++ ")"
52chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
53chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p
55chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
56chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p
58wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
59wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p
61split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
62split s f p = (s >>> A.arr (uncurry f)) <|> p
64data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }
66data Operator a r where
67 AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
68 AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
69 Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
70 Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
72buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
73buildPrettyPrinter table p = foldl (\p' op ->
74 case op of
75 AssocL pat g -> chainl pat g p'
76 AssocR pat g -> chainr pat g p'
77 Wrap pat g -> wrap pat g p'
78 Split pat g -> split pat g p'
79 ) p $ runOperatorTable table