git.iko.soy/rowtype-yoga/purescript-native
on bcc7e77 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/CaseDeclarations.hs
67 lines 2.4 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 desugarCasesModule
18) where
20import Data.List (groupBy)
21import Control.Applicative ((<$>))
22import Control.Monad (forM, join, unless)
23import Control.Monad.Error.Class
25import Language.PureScript.Names
26import Language.PureScript.Values
27import Language.PureScript.Declarations
28import Language.PureScript.Scope
30desugarCasesModule :: [Module] -> Either String [Module]
31desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds
33desugarCases :: [Declaration] -> Either String [Declaration]
34desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
36inSameGroup :: Declaration -> Declaration -> Bool
37inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
38inSameGroup _ _ = False
40toDecls :: [Declaration] -> Either String [Declaration]
41toDecls d@[ValueDeclaration _ [] Nothing _] = return d
42toDecls ds@(ValueDeclaration ident bs _ _ : _) = do
43 let tuples = map toTuple ds
44 unless (all ((== map length bs) . map length . fst) tuples) $
45 throwError $ "Argument list lengths differ in declaration " ++ show ident
46 return [makeCaseDeclaration ident tuples]
47toDecls ds = return ds
49toTuple :: Declaration -> ([[Binder]], (Maybe Guard, Value))
50toTuple (ValueDeclaration _ bs g val) = (bs, (g, val))
51toTuple _ = error "Not a value declaration"
53makeCaseDeclaration :: Ident -> [([[Binder]], (Maybe Guard, Value))] -> Declaration
54makeCaseDeclaration ident alternatives =
55 let
56 argPattern = map length . fst . head $ alternatives
57 args = take (sum argPattern) $ unusedNames (ident, alternatives)
58 vars = map (\arg -> Var (Qualified Nothing arg)) args
59 binders = [ (join bs, g, val) | (bs, (g, val)) <- alternatives ]
60 value = foldr (\args' ret -> Abs args' ret) (Case vars binders) (rearrange argPattern args)
61 in
62 ValueDeclaration ident [] Nothing value
64rearrange :: [Int] -> [a] -> [[a]]
65rearrange [] _ = []
66rearrange (n:ns) xs = take n xs : rearrange ns (drop n xs)