git.iko.soy/rowtype-yoga/purescript-native
on 1301ee6 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/CaseDeclarations.hs
62 lines 2.2 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 ds = return ds
44toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
45toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
46toTuple _ = error "Not a value declaration"
48makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
49makeCaseDeclaration ident alternatives =
50 let
51 argPattern = map length . fst . head $ alternatives
52 args = take (sum argPattern) $ unusedNames (ident, alternatives)
53 vars = map (\arg -> Var (Qualified global arg)) args
54 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
55 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
56 in
57 ValueDeclaration ident [] Nothing value
59rearrange :: [Int] -> [a] -> [[a]]
60rearrange [] _ = []
61rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)