942ee24 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Use user-defined type variables whenever possible

942ee24Evan Czaplicki10 years ago

src/Type/Solve.hs+2−2

compare with master

unifiedsplit

@@ -71,8 +71,8 @@ generalize youngPool =

71rigidify :: Content -> Content

72rigidify content =

73 case content of

74− Var Flex maybeSuper _ ->

74+ Var Flex maybeSuper maybeName ->

75− Var Rigid maybeSuper Nothing

75+ Var Rigid maybeSuper maybeName

77 _ ->

78 content

src/Type/State.hs+2−2

@@ -223,8 +223,8 @@ makeCopyHelp descriptor alreadyCopiedMark variable =

223 Atom _ ->

224 return oldContent

225

226− Var Rigid maybeSuper _ ->

226+ Var Rigid maybeSuper maybeName ->

227− return (Var Flex maybeSuper Nothing)

227+ return (Var Flex maybeSuper maybeName)

228

229 Var Flex _ _ ->

230 return oldContent

src/Type/Type.hs+128−83

@@ -1,12 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2module Type.Type where

4+import Control.Monad (when)

4import Control.Monad.State (StateT, liftIO)

5import Control.Monad.State (StateT, liftIO)

5import qualified Control.Monad.State as State

6import qualified Control.Monad.State as State

7+import qualified Data.Char as Char

6import qualified Data.List as List

8import qualified Data.List as List

7import qualified Data.Map as Map

9import qualified Data.Map as Map

8−import qualified Data.Set as Set

9−import qualified Data.Traversable as Traverse (traverse)

10import qualified Data.UnionFind.IO as UF

12import qualified AST.Type as T

@@ -185,13 +185,7 @@ mkVar maybeSuper =

185

186mkNamedVar :: Flex -> String -> IO Variable

187mkNamedVar flex name =

188− UF.fresh $ mkDescriptor $ Var flex (toSuper name) $

188+ UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)

189− case flex of

190− Flex ->

191− Nothing

192−

193− Rigid ->

194− Just name

195

189

196

190

197toSuper :: String -> Maybe Super

191toSuper :: String -> Maybe Super

@@ -259,8 +253,8 @@ existsNumber f =

259-- never have to do extra work, particularly nice for aliased types

253-- never have to do extra work, particularly nice for aliased types

260toSrcType :: Variable -> IO T.Canonical

254toSrcType :: Variable -> IO T.Canonical

261toSrcType variable =

255toSrcType variable =

262− do usedNames <- getVarNames variable

256+ do takenNames <- State.execStateT (getVarNames variable) Map.empty

263− State.evalStateT (variableToSrcType variable) (makeNameState usedNames)

257+ State.evalStateT (variableToSrcType variable) (makeNameState takenNames)

264

258

265

259

266variableToSrcType :: Variable -> StateT NameState IO T.Canonical

260variableToSrcType :: Variable -> StateT NameState IO T.Canonical

@@ -297,7 +291,7 @@ contentToSrcType variable content =

297 return (T.Var freshName)

291 return (T.Var freshName)

298

292

299 Alias name args realVariable ->

293 Alias name args realVariable ->

300− do srcArgs <- mapM (\(arg,tvar) -> (,) arg <$> variableToSrcType tvar) args

294+ do srcArgs <- traverse (traverse variableToSrcType) args

301 srcType <- variableToSrcType realVariable

295 srcType <- variableToSrcType realVariable

302 return (T.Aliased name srcArgs (T.Filled srcType))

296 return (T.Aliased name srcArgs (T.Filled srcType))

303

297

@@ -327,7 +321,7 @@ termToSrcType term =

327 return $ T.Record [] Nothing

321 return $ T.Record [] Nothing

328

322

329 Record1 fields extension ->

323 Record1 fields extension ->

330− do srcFields <- Map.toList <$> Traverse.traverse variableToSrcType fields

324+ do srcFields <- Map.toList <$> traverse variableToSrcType fields

331 srcExt <- T.iteratedDealias <$> variableToSrcType extension

325 srcExt <- T.iteratedDealias <$> variableToSrcType extension

332 return $

326 return $

333 case srcExt of

327 case srcExt of

@@ -346,112 +340,163 @@ termToSrcType term =

346

340

347

341

348data NameState = NameState

342data NameState = NameState

349− { _freeNames :: [String]

343+ { _taken :: TakenNames

350− , _numberPrimes :: Int

344+ , _normals :: Int

351− , _comparablePrimes :: Int

345+ , _numbers :: Int

352− , _appendablePrimes :: Int

346+ , _comparables :: Int

353− , _compAppendPrimes :: Int

347+ , _appendables :: Int

348+ , _compAppends :: Int

354 }

349 }

355

350

356

351

357−makeNameState :: Set.Set String -> NameState

352+type TakenNames = Map.Map String Variable

358−makeNameState usedNames =

359− let

360− makeName suffix =

361− map (:suffix) ['a'..'z']

362

353

363− allNames =

364− concatMap makeName ("" : map show [ (1 :: Int) .. ])

365

354

366− freeNames =

355+makeNameState :: TakenNames -> NameState

367− filter (\name -> Set.notMember name usedNames) allNames

356+makeNameState taken =

368− in

369− NameState freeNames 0 0 0 0

357+ NameState taken 0 0 0 0 0

370

358

371

359

372getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

360getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

373getFreshName maybeSuper =

361getFreshName maybeSuper =

374 case maybeSuper of

362 case maybeSuper of

375 Nothing ->

363 Nothing ->

376− do names <- State.gets _freeNames

364+ do index <- State.gets _normals

365+ taken <- State.gets _taken

366+ let (uniqueName, newIndex) = getFreshNormal index taken

377− State.modify (\state -> state { _freeNames = tail names })

367+ State.modify (\state -> state { _normals = newIndex })

378− return (head names)

368+ return uniqueName

379

369

380 Just Number ->

370 Just Number ->

381− do primes <- State.gets _numberPrimes

371+ getFreshSuper "number" _numbers (\index state -> state { _numbers = index })

382− State.modify (\state -> state { _numberPrimes = primes + 1 })

383− return ("number" ++ replicate primes '\'')

384

372

385 Just Comparable ->

373 Just Comparable ->

386− do primes <- State.gets _comparablePrimes

374+ getFreshSuper "comparable" _comparables (\index state -> state { _comparables = index })

387− State.modify (\state -> state { _comparablePrimes = primes + 1 })

388− return ("comparable" ++ replicate primes '\'')

389

375

390 Just Appendable ->

376 Just Appendable ->

391− do primes <- State.gets _appendablePrimes

377+ getFreshSuper "appendable" _appendables (\index state -> state { _appendables = index })

392− State.modify (\state -> state { _appendablePrimes = primes + 1 })

393− return ("appendable" ++ replicate primes '\'')

394

378

395 Just CompAppend ->

379 Just CompAppend ->

396− do primes <- State.gets _compAppendPrimes

380+ getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })

397− State.modify (\state -> state { _compAppendPrimes = primes + 1 })

381+

398− return ("compappend" ++ replicate primes '\'')

382+

383+getFreshNormal :: Int -> TakenNames -> (String, Int)

384+getFreshNormal index taken =

385+ let

386+ (postfix, letter) =

387+ quotRem index 26

388+

389+ name =

390+ Char.chr (97 + letter) : if postfix <= 0 then "" else show postfix

391+ in

392+ if Map.member name taken then

393+ getFreshNormal (index + 1) taken

394+

395+ else

396+ (name, index + 1)

397+

398+

399+getFreshSuper

400+ :: (Monad m)

401+ => String

402+ -> (NameState -> Int)

403+ -> (Int -> NameState -> NameState)

404+ -> StateT NameState m String

405+getFreshSuper name getter setter =

406+ do index <- State.gets getter

407+ taken <- State.gets _taken

408+ let (uniqueName, newIndex) = getFreshSuperHelp name index taken

409+ State.modify (setter newIndex)

410+ return uniqueName

411+

412+

413+getFreshSuperHelp :: String -> Int -> TakenNames -> (String, Int)

414+getFreshSuperHelp name index taken =

415+ let

416+ newName =

417+ if index <= 0 then name else name ++ show index

418+ in

419+ if Map.member newName taken then

420+ getFreshSuperHelp name (index + 1) taken

421+

422+ else

423+ (newName, index + 1)

399

424

400

425

401

426

402-- GET ALL VARIABLE NAMES

427-- GET ALL VARIABLE NAMES

403

428

404

429

405−getVarNames :: Variable -> IO (Set.Set String)

430+getVarNames :: Variable -> StateT TakenNames IO ()

406getVarNames var =

431getVarNames var =

407− do desc <- UF.descriptor var

432+ do desc <- liftIO $ UF.descriptor var

408− if _mark desc == getVarNamesMark

433+ case _mark desc == getVarNamesMark of

409− then

434+ True ->

410− return Set.empty

435+ return ()

411

436

412− else

437+ False ->

413− do UF.setDescriptor var (desc { _mark = getVarNamesMark })

438+ do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })

414− getVarNamesHelp (_content desc)

439+ case _content desc of

440+ Atom _ ->

441+ return ()

415

442

443+ Error ->

444+ return ()

416

445

417−getVarNamesHelp :: Content -> IO (Set.Set String)

418−getVarNamesHelp content =

419− case content of

420− Var _ _ (Just name) ->

446+ Var _ _ Nothing ->

421− return (Set.singleton name)

447+ return ()

422

448

423− Var _ _ Nothing ->

449+ Var flex maybeSuper (Just name) ->

424− return Set.empty

450+ do oldTaken <- State.get

451+ newTaken <- liftIO $ addVarName 0 name var flex maybeSuper oldTaken

452+ State.put newTaken

425

453

426− Structure term ->

454+ Alias _ args realVar ->

427− getVarNamesTerm term

455+ do mapM_ (getVarNames . snd) args

456+ getVarNames realVar

428

457

429− Alias _name args realVar ->

458+ Structure (App1 func arg) ->

430− do let argSet = Set.fromList (map fst args)

431− realSet <- getVarNames realVar

459+ do getVarNames func

432− sets <- mapM (getVarNames . snd) args

460+ getVarNames arg

433− return (Set.unions (realSet : argSet : sets))

434

461

435− Atom _ ->

462+ Structure (Fun1 arg body) ->

436− return Set.empty

463+ do getVarNames arg

464+ getVarNames body

437

465

438− Error ->

466+ Structure EmptyRecord1 ->

439− return Set.empty

467+ return ()

440

468

469+ Structure (Record1 fields extension) ->

470+ do mapM_ getVarNames fields

471+ getVarNames extension

441

472

442−getVarNamesTerm :: Term1 Variable -> IO (Set.Set String)

443−getVarNamesTerm term =

444− let go = getVarNames in

445− case term of

446− App1 a b ->

447− Set.union <$> go a <*> go b

448

473

449− Fun1 a b ->

474+addVarName :: Int -> String -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames

450− Set.union <$> go a <*> go b

475+addVarName index givenName var flex maybeSuper taken =

476+ let

477+ name =

478+ makeIndexedName givenName index

479+ in

480+ case Map.lookup name taken of

481+ Nothing ->

482+ do when (name /= givenName) $ UF.modifyDescriptor var $ \desc ->

483+ desc { _content = Var flex maybeSuper (Just name) }

484+ return $ Map.insert name var taken

451

485

452− EmptyRecord1 ->

486+ Just otherVar ->

453− return Set.empty

487+ do same <- UF.equivalent var otherVar

488+ if same

489+ then return taken

490+ else addVarName (index + 1) givenName var flex maybeSuper taken

454

491

455− Record1 fields extension ->

492+

456− do fieldVars <- Set.unions <$> mapM go (Map.elems fields)

493+makeIndexedName :: String -> Int -> String

457− Set.union fieldVars <$> go extension

494+makeIndexedName name index =

495+ if index <= 0 then

496+ name

497+

498+ else if Char.isDigit (last name) then

499+ name ++ '_' : show index

500+

501+ else

502+ name ++ show index