git.iko.soy/rowtype-yoga/purescript-native
on e22e8e7 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/CaseDeclarations.hs
56 lines 2.0 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript.CaseDeclarations
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-----------------------------------------------------------------------------
15module Language.PureScript.CaseDeclarations (
16 desugarCases
17) where
19import Data.List (groupBy)
20import Control.Monad (join, unless)
21import Control.Monad.Error.Class
22import Language.PureScript.Names
23import Language.PureScript.Values
24import Language.PureScript.Declarations
26desugarCases :: [Declaration] -> Either String [Declaration]
27desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
29inSameGroup :: Declaration -> Declaration -> Bool
30inSameGroup (ValueDeclaration ident1 _ _) (ValueDeclaration ident2 _ _) = ident1 == ident2
31inSameGroup _ _ = False
33toDecls :: [Declaration] -> Either String [Declaration]
34toDecls d@[ValueDeclaration _ [] _] = return d
35toDecls ds@(ValueDeclaration ident bs _ : _) = do
36 let pairs = map toPair ds
37 unless (all ((== length bs) . length . fst) pairs) $
38 throwError $ "Argument list lengths differ in declaration " ++ show pairs
39 return [makeCaseDeclaration ident pairs]
40toDecls ds = return ds
42toPair :: Declaration -> ([Binder], Value)
43toPair (ValueDeclaration _ bs val) = (bs, val)
44toPair _ = error "Not a value declaration"
46makeCaseDeclaration :: Ident -> [([Binder], Value)] -> Declaration
47makeCaseDeclaration ident alternatives =
48 let
49 numArgs = length (fst . head $ alternatives)
50 args = map (('_' :) . show) [1..numArgs]
51 obj = ObjectLiteral $ map (\arg -> (arg, Var (Qualified global (Ident arg)))) args
52 objBinders = [ (ObjectBinder (zip args bs), val) | (bs, val) <- alternatives ]
53 value = foldr (\arg ret -> Abs [Ident arg] ret) (Case obj objBinders) args
54 in
55 ValueDeclaration ident [] value