git.iko.soy/rowtype-yoga/purescript-native
on f98236e help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen/Common.hs
80 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.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, A.ArrowZero, A.ArrowPlus)
44instance Functor (Pattern a) where
45 fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
47pattern :: Pattern a b -> a -> Maybe b
48pattern = A.runKleisli . runPattern
50parens :: String -> String
51parens s = ('(':s) ++ ")"
53chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
54chainl split f p = fix $ \c -> split >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
56chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
57chainr split f p = fix $ \c -> split >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
59wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
60wrap split f p = fix $ \c -> split >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
62split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
63split s f p = s >>> A.arr (uncurry f)
65data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }
67data Operator a r where
68 AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
69 AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
70 Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
71 Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
73buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
74buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
75 case op of
76 AssocL pat g -> chainl pat g p'
77 AssocR pat g -> chainr pat g p'
78 Wrap pat g -> wrap pat g p'
79 Split pat g -> split pat g p'
80 ) <+> p') p $ runOperatorTable table