git.iko.soy/rowtype-yoga/purescript-native
on 80a4d8e help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen/Common.hs
88 lines 3.0 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.Char
20import Data.Maybe (fromMaybe)
21import Data.List (nub, intersperse, intercalate)
22import Data.Function (fix)
23import Control.Monad.State
24import Control.Applicative (Applicative(..), Alternative(..))
25import qualified Control.Category as C
26import Control.Category ((>>>))
27import qualified Control.Arrow as A
28import Control.Arrow ((***))
30import PureScript.Names
31import PureScript.Values
32import PureScript.Types
33import PureScript.Declarations
35identToJs :: Ident -> String
36identToJs (Ident name) = name
37identToJs (Op op) = concatMap opCharToString op
38 where
39 opCharToString :: Char -> String
40 opCharToString = (:) '$'. show . ord
42newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)
44pattern :: Pattern a b -> a -> Maybe b
45pattern = A.runKleisli . runPattern
47instance Functor (Pattern a) where
48 fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p
50instance Applicative (Pattern a) where
51 pure = Pattern . A.Kleisli . const . pure
52 f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a
54instance Alternative (Pattern a) where
55 empty = Pattern $ A.Kleisli $ \a -> empty
56 (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a
58parens :: String -> String
59parens s = ('(':s) ++ ")"
61chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
62chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p
64chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
65chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p
67wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
68wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p
70split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
71split s f p = (s >>> A.arr (uncurry f)) <|> p
73data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }
75data Operator a r where
76 AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
77 AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
78 Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
79 Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
81buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
82buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<|>) (flip map ops $ \op ->
83 case op of
84 AssocL pat g -> chainl pat g p'
85 AssocR pat g -> chainr pat g p'
86 Wrap pat g -> wrap pat g p'
87 Split pat g -> split pat g p'
88 )) p $ runOperatorTable table