git.iko.soy/rowtype-yoga/purescript-native
on e483b1d help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/CaseDeclarations.hs
65 lines 2.3 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
23import Language.PureScript.Names
24import Language.PureScript.Values
25import Language.PureScript.Declarations
26import Language.PureScript.Scope
28desugarCases :: [Declaration] -> Either String [Declaration]
29desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
31inSameGroup :: Declaration -> Declaration -> Bool
32inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
33inSameGroup _ _ = False
35toDecls :: [Declaration] -> Either String [Declaration]
36toDecls d@[ValueDeclaration _ [] Nothing _] = return d
37toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
38 let tuples = map toTuple ds
39 unless (all ((== map length bs) . map length . fst) tuples) $
40 throwError $ "Argument list lengths differ in declaration " ++ show ident
41 return [makeCaseDeclaration ident tuples]
42toDecls [ModuleDeclaration name decls] = do
43 desugared <- desugarCases decls
44 return [ModuleDeclaration name desugared]
45toDecls ds = return ds
47toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
48toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
49toTuple _ = error "Not a value declaration"
51makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
52makeCaseDeclaration ident alternatives =
53 let
54 argPattern = map length . fst . head $ alternatives
55 args = take (sum argPattern) $ unusedNames (ident, alternatives)
56 vars = map (\arg -> Var (Qualified global arg)) args
57 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
58 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
59 in
60 ValueDeclaration ident [] Nothing value
62rearrange :: [Int] -> [a] -> [[a]]
63rearrange [] _ = []
64rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)